matterhorn 50200.0.0 → 50200.1.0
raw patch · 56 files changed
+3165/−1880 lines, 56 filesdep +data-clistdep ~aesondep ~brickdep ~brick-skylighting
Dependencies added: data-clist
Dependency ranges changed: aeson, brick, brick-skylighting, mattermost-api, mattermost-api-qc, temporary, vty
Files
- CHANGELOG.md +146/−2
- README.md +12/−1
- matterhorn.cabal +19/−12
- notification-scripts/notify +1/−1
- src/App.hs +4/−1
- src/Command.hs +20/−4
- src/Completion.hs +0/−79
- src/Config.hs +1/−0
- src/Connection.hs +34/−12
- src/Draw.hs +3/−0
- src/Draw/Autocomplete.hs +135/−0
- src/Draw/ChannelList.hs +103/−193
- src/Draw/Main.hs +30/−73
- src/Draw/ManageAttachments.hs +61/−0
- src/Draw/Messages.hs +1/−1
- src/Draw/PostListOverlay.hs +1/−3
- src/Draw/ShowHelp.hs +7/−15
- src/Draw/URLList.hs +53/−0
- src/Draw/UserListOverlay.hs +11/−9
- src/Draw/Util.hs +14/−4
- src/Events.hs +75/−150
- src/Events/ChannelScroll.hs +4/−2
- src/Events/ChannelSelect.hs +10/−16
- src/Events/Keybindings.hs +104/−0
- src/Events/Main.hs +61/−103
- src/Events/ManageAttachments.hs +146/−0
- src/KeyMap.hs +30/−0
- src/Main.hs +8/−3
- src/Markdown.hs +25/−13
- src/Options.hs +5/−0
- src/Scripts.hs +7/−5
- src/State/Async.hs +11/−11
- src/State/Attachments.hs +35/−0
- src/State/Autocomplete.hs +197/−0
- src/State/ChannelSelect.hs +62/−93
- src/State/Channels.hs +388/−284
- src/State/Common.hs +93/−27
- src/State/Editing.hs +43/−25
- src/State/Flagging.hs +5/−4
- src/State/MessageSelect.hs +6/−26
- src/State/Messages.hs +141/−107
- src/State/Messages.hs-boot +11/−0
- src/State/PostListOverlay.hs +4/−4
- src/State/Reactions.hs +1/−1
- src/State/Setup.hs +32/−17
- src/State/Setup/Threads.hs +49/−37
- src/State/UrlSelect.hs +1/−1
- src/State/UserListOverlay.hs +68/−61
- src/State/Users.hs +77/−16
- src/Themes.hs +56/−0
- src/Types.hs +542/−331
- src/Types/Channels.hs +73/−23
- src/Types/Common.hs +21/−1
- src/Types/KeyEvents.hs +17/−0
- src/Types/Users.hs +28/−58
- src/Zipper.hs +73/−51
CHANGELOG.md view
@@ -1,4 +1,148 @@ +50200.1.0+=========++This release contains many new features and changes. Please read+carefully!++New features:++ * Matterhorn is now supported on CentOS 7. See the GitHub release tag+ for a prebuilt CentOS 7 binary.+ * Matterhorn's channel sidebar has changed significantly:+ * Matterhorn now only shows recently-active DM channels in the+ sidebar rather than showing all users. This change brings+ Matterhorn closer to the behavior of the official web client and+ reduces clutter. However, this change may be disorienting since+ previously all users were shown in the sidebar. To begin a chat+ with a user absent from your sidebar, use the `/msg` command.+ * The sidebar channel group headings have been renamed to reflect the+ new changes and to match those of the official web client.+ * Group DM channels are now displayed in the new Direct Messages+ section along with one-on-one DM channels.+ * Each channel group heading now displays an asterisk if any channels+ in that group have unread activity.+ * The autocompletion user interface has been dramatically improved.+ * The command completion UI now appears automatically if the user+ types a slash at the beginning of the prompt. Any text typed after+ the slash is matched case-insensitively on all client-side command+ names and descriptions, with a preference for matching command+ names. Tab then cycles through the displayed alternatives.+ * The user completion UI now appears automatically if the user enters+ a user sigil ("@"). Text typed after the sigil searches usernames,+ nicknames, and full names. Users in the current channel appear+ first and users not in the current channel appear next, marked with+ an asterisk and a help hint. Tab cycles through completion of the+ alternatives.+ * The channel completion UI now appears automatically if the user+ enters a channel sigil ("~"). Text typed after the sigil searches+ channel names, headers, and purposes. Channels of which the user+ is a member are listed first, with other channels following. Tab+ cycles through completion of the alternatives.+ * The fenced code block language name completion UI now appears+ automatically if the user types three backticks to begin a code+ block. Text following the backticks searches known language names+ case-insensitively with a preference for prefix match. Tab cycles+ through the alternatives.+ * Matterhorn now supports adding attachments to posts:+ * The default binding of `C-x` shows a file browser.+ * `Enter` in the file browser selects a regular file for attachment+ (or, if used on a directory, navigates to that directory in the+ browser).+ * The default cancellation binding of `Esc` closes the browser.+ * The default binding of `o` opens the selected browser entry using+ the URL opening command.+ * Once a file is attached, an attachment count is displayed above the+ message editor.+ * Pressing `C-x` again will open the attachment list for the current+ post, where existing attachments can be removed (`d`) or new ones+ can be added (`a`).+ * The channel selection mode (`C-g`) user input is now performed with a+ line editor, meaning that all of the text-editing keybindings that+ are supported in the message editor are now supported in channel+ selection mode.+ * Channel sidebar cycling keys (`C-n`, `C-p`) now cycle through all+ channels including DM channels, not just non-DM channels as before.++New commands:++ * `/reconnect`: forces a disconnection and reconnection of Matterhorn's+ websocket connection in case of network connection trouble.+ Ordinarily Matterhorn will time out and determine that its connection+ needs to be reestablished, but this command may be useful for other+ situations.+ * `/hide`: hides the current single-user or group direct message+ channel from the sidebar. The channel will reappear later if new+ messages arrive in the channel.++New key events:++ * `show-attachment-list` (default `C-x`): show the attachment list or+ file browser to attach a file to the current post.+ * `add-to-attachment-list` (default `a`): in the attachment list, open+ the file browser to select an additional file to attach to the+ current post.+ * `delete-from-attachment-list` (default `d`): in the attachment list,+ delete the selected pending attachment. (This does not affect the+ original disk file.)+ * `open-attachment` (default `o`): in the attachment list or file+ browser, open the selected file or attachment with the URL opening+ command, if one is configured.++New theme attributes:++ * `fileBrowser`: the base attribute for the attachment file browser.+ * `fileBrowser.currentDirectory`: the attribute for the file browser's+ heading displaying its working directory.+ * `fileBrowser.selectionInfo`: the attribute for the file browser's+ footer displaying information about the selected file or directory.+ * `fileBrowser.directory`: the attribute used for directories in the+ file browser.+ * `fileBrowser.block`: the attribute used for block devices in the file+ browser.+ * `fileBrowser.regular`: the attribute used for regular files in the+ file browser.+ * `fileBrowser.char`: the attribute used for character devices in the+ file browser.+ * `fileBrowser.pipe`: the attribute used for named pipes in the file+ browser.+ * `fileBrowser.symlink`: the attribute used for symbolic links in the+ file browser.+ * `fileBrowser.unixSocket`: the attribute used for Unix sockets in the+ file browser.++New command-line options:++ * `-i`/`--ignore-config`: start Matterhorn with no configuration, i.e.,+ ignore the default configuration.++Performance improvements:++ * Matterhorn now renders its user interface more efficiently, resulting+ in improved input latency, especially on larger window sizes.+ * Matterhorn now makes fewer requests on startup, resulting in lower+ server API burden and improved startup performance.+ * Message username and channel name highlighting is now more efficient.++Bug fixes:++ * Username highlighting in messages now supports usernames containing+ periods and underscores (#373)+ * Matterhorn will now ask for a keypress if an interactive URL opener+ exits with a non-zero exit status, to allow the user to observe any+ error output before returning to Matterhorn (#462)+ * `/group-msg` now supports username arguments with sigils.+ * Matterhorn now properly updates channel view timestamps under the+ right conditions (#449)+ * The bundled `notify` script now uses `bash`, not `sh`, to get+ extended `[` functionality.++Miscellaneous:++ * The help interface now takes up the entire screen when it is active.+ * The user list overlay for `/msg` now respects the direct message+ restriction server setting (#378).+ 50200.0.0 ========= @@ -12,8 +156,8 @@ * With the customized keybinding name of `toggle-channel-list-visibility` * The account preference for teammate name display is now honored and- precedence over the server default; at present, only the "nickname"- and "username" settings are supported.+ takes precedence over the server default; at present, only the+ "nickname" and "username" settings are supported. * Channel selection mode now matches case-insensitively if the input is entirely lowercase and matches case-sensitively otherwise. * Non-public channels now include their privacy level in the channel
README.md view
@@ -135,6 +135,15 @@ choice of master dictionary, set the `aspellDictionary` option to the name of the dictionary you'd like to use. +To attach a file to the post being edited, use the default binding of+`C-x`. The window that appears will let you browse the filesystem to+find a file to attach. In this window, `o` opens the selected file with+your URL open command to let you preview your choice, `Enter` enters the+selected directory or selects the current file for attachment, and arrow+keys change selection. Once you've attached a file, you'll see the text+`(1 attachment)` above your message editor. You can attach additional+files or remove existing attachments by pressing `C-x` again.+ # Features * Channel creation, deletion, and membership management commands@@ -149,7 +158,9 @@ * Edit messages with `$EDITOR` * Rebindable keys (see `/help keybindings`) * Message editor with kill/yank buffer and readline-style keybindings-* Tab-completion of usernames, channel names, and commands+* Tab-completion of usernames, channel names, commands, and fence code+ block languages+* Support for attachment upload and download * Spell-checking via Aspell * Syntax highlighting of fenced code blocks in messages (works best in 256-color terminals)
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 50200.0.0+version: 50200.1.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@@ -36,11 +36,12 @@ other-modules: Config Command Connection- Completion App Clipboard Constants State.Async+ State.Attachments+ State.Autocomplete State.Channels State.ChannelScroll State.ChannelSelect@@ -63,6 +64,8 @@ Zipper Themes Draw+ Draw.ManageAttachments+ Draw.Autocomplete Draw.Main Draw.Messages Draw.ChannelList@@ -72,11 +75,13 @@ Draw.PostListOverlay Draw.UserListOverlay Draw.JoinChannel+ Draw.URLList Draw.Util Draw.ViewMessage InputHistory IOUtil Events+ Events.ManageAttachments Events.Keybindings Events.ShowHelp Events.MessageSelect@@ -91,6 +96,7 @@ Events.DeleteChannelConfirm Events.ViewMessage HelpTopics+ KeyMap LastRunState Scripts TimeUtils@@ -115,10 +121,11 @@ NoImplicitPrelude ghc-options: -Wall -threaded -with-rtsopts=-I0 build-depends: base >=4.8 && <5- , mattermost-api == 50200.0.0+ , mattermost-api == 50200.1.0 , base-compat >= 0.9 && < 0.11 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6+ , data-clist >= 0.1.2 && < 0.2 , semigroups >= 0.18 && < 0.19 , connection >= 0.2 && < 0.3 , text >= 1.2 && < 1.3@@ -127,9 +134,9 @@ , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.4- , brick >= 0.39 && < 0.40- , brick-skylighting >= 0.2 && < 0.3- , vty >= 5.23.1 && < 5.24+ , brick >= 0.42.1 && < 0.43+ , brick-skylighting >= 0.2 && < 0.4+ , vty >= 5.23.1 && < 5.26 , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.10 && < 0.11@@ -142,7 +149,7 @@ , hashable >= 1.2 && < 1.3 , cheapskate >= 0.1 && < 0.2 , utf8-string >= 1.0 && < 1.1- , temporary >= 1.2 && < 1.3+ , temporary >= 1.2 && < 1.4 , gitrev >= 1.3 && < 1.4 , Hclip >= 3.0 && < 3.1 , mtl >= 2.2 && < 2.3@@ -152,7 +159,7 @@ , skylighting-core >= 0.7 && < 0.8 , timezone-olson >= 0.1.7 && < 0.2 , timezone-series >= 0.1.6.1 && < 0.2- , aeson >= 1.2.3.0 && < 1.3+ , aeson >= 1.2.3.0 && < 1.4 , async >= 2.2 && < 2.3 , uuid >= 1.3 && < 1.4 , random >= 1.1 && < 1.2@@ -176,7 +183,7 @@ hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.11- , brick >= 0.39 && < 0.40+ , brick >= 0.42.1 && < 0.43 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.5@@ -187,8 +194,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1- , mattermost-api == 50200.0.0- , mattermost-api-qc == 50200.0.0+ , mattermost-api == 50200.1.0+ , mattermost-api-qc == 50200.1.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7@@ -208,7 +215,7 @@ , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3 , vector <= 0.12.0.1- , vty >= 5.23.1 && < 5.24+ , vty >= 5.23.1 && < 5.26 , xdg-basedir >= 0.2 && < 0.3 , semigroups >= 0.18 && < 0.19 , uuid >= 1.3 && < 1.4
notification-scripts/notify view
@@ -1,4 +1,4 @@-#!/bin/sh+#!/usr/bin/env bash # Sample shell script for using notify-send with matterhorn This script # works on Linux only. It depends on the 'notify-send' command.
src/App.hs view
@@ -29,7 +29,10 @@ app :: App ChatState MHEvent Name app = App { appDraw = draw- , appChooseCursor = showFirstCursor+ , appChooseCursor = \s cs -> case appMode s of+ ManageAttachments -> Nothing+ ManageAttachmentsBrowseFiles -> Nothing+ _ -> showFirstCursor s cs , appHandleEvent = onEvent , appStartEvent = return , appAttrMap = (^.csResources.crTheme)
src/Command.hs view
@@ -4,26 +4,29 @@ ( 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 HelpTopics import Scripts import State.Help import State.Channels import State.ChannelSelect-import State.Editing ( toggleMessagePreview ) import State.Logging import State.PostListOverlay import State.Themes@@ -82,6 +85,14 @@ NoArg $ \ () -> beginCurrentChannelDeleteConfirm + , Cmd "hide" "Hide the current DM or group channel from the channel list"+ NoArg $ \ () ->+ hideCurrentDMChannel++ , Cmd "reconnect" "Force a reconnection attempt to the server"+ NoArg $ \ () ->+ connectWebsockets+ , Cmd "members" "Show the current channel's members" NoArg $ \ () -> enterChannelMembersUserList@@ -132,7 +143,7 @@ , Cmd "add-user" "Add a user to the current channel" (TokenArg "username" NoArg) $ \ (uname, ()) ->- addUserToCurrentChannel uname+ addUserByNameToCurrentChannel uname , Cmd "remove-user" "Remove a user from the current channel" (TokenArg "username" NoArg) $ \ (uname, ()) ->@@ -146,7 +157,7 @@ , Cmd "focus" "Focus on a channel or user" (TokenArg "channel" NoArg) $ \ (name, ()) ->- changeChannel name+ changeChannelByName name , Cmd "focus" "Select from available channels" NoArg $ \ () -> beginChannelSelect@@ -178,7 +189,7 @@ (LineArg "message") $ \msg -> execMMCommand "shrug" msg - , Cmd "flags" "Open up a pane of flagged posts" NoArg $ \ () ->+ , Cmd "flags" "Open a window of your flagged posts" NoArg $ \ () -> enterFlaggedPostListMode , Cmd "search" "Search for posts with given terms" (LineArg "terms") $@@ -246,3 +257,8 @@ Left e -> go (e:errs) cs Right args -> exe args _ -> return ()++toggleMessagePreview :: MH ()+toggleMessagePreview = do+ mh invalidateCache+ csShowMessagePreview %= not
− src/Completion.hs
@@ -1,79 +0,0 @@--- Heavily inspired by tab completion from glirc:--- https://github.com/glguy/irc-core/blob/v2/src/Client/Commands/WordCompletion.hs-module Completion- ( Completer(..)- , CompletionAlternative(..)- , wordComplete- , currentAlternative- , nextCompletion- , previousCompletion- )-where--import Prelude ()-import Prelude.MH--import Data.Char ( isSpace )-import qualified Data.Set as Set-import qualified Data.Text as T--import qualified Zipper as Z----- A completer stores the stateful selection of a completion alternative--- from a sequence of alternatives.-data Completer =- Completer { completionAlternatives :: Z.Zipper CompletionAlternative- }---- A completion alternative is made up of various representations:--- the string corresonding to the user input, the string that will--- ultimately replace the user's input, and the the string that we will--- display in the alternative list. The representations are decoupled--- specifically to deal with permitting nickname completions to--- "resolve" to usernames and to permit completions in context-sensitive--- settings where the completion replacement and display differ greatly--- from the input.-data CompletionAlternative =- CompletionAlternative { completionInput :: Text- , completionReplacement :: Text- , completionDisplay :: Text- }- deriving (Ord, Eq)--matchesAlternative :: Text -> CompletionAlternative -> Bool-matchesAlternative input alt =- T.toLower input `T.isPrefixOf` (T.toLower $ completionInput alt)---- Nothing: no completions.--- Just Left: a single completion.--- Just Right: more than one completion.-wordComplete :: Set CompletionAlternative -> Text -> Maybe (Either Text Completer)-wordComplete options input =- let curWord = currentWord input- alts = sort $ Set.toList $ Set.filter (matchesAlternative curWord) options- in if null alts || T.null curWord- then Nothing- else if length alts == 1- then Just $ Left $ completionReplacement $ head alts- else Just $ Right $ Completer { completionAlternatives = Z.fromList alts- }--currentAlternative :: Completer -> CompletionAlternative-currentAlternative = Z.focus . completionAlternatives--nextCompletion :: Completer -> Completer-nextCompletion (Completer z) = Completer $ Z.right z--previousCompletion :: Completer -> Completer-previousCompletion (Completer z) = Completer $ Z.left z---- | trim whitespace and do any other edits we need--- to focus on the current word-currentWord :: Text -> Text-currentWord line- = T.reverse- $ T.takeWhile (not . isSpace)- $ T.dropWhile (\x -> x==' ' || x==':')- $ T.reverse- $ line
src/Config.hs view
@@ -6,6 +6,7 @@ , PasswordSource(..) , findConfig , getCredentials+ , defaultConfig ) where
src/Connection.hs view
@@ -4,9 +4,9 @@ import Prelude.MH import Brick.BChan-import Control.Concurrent ( forkIO, threadDelay )+import Control.Concurrent ( forkIO, threadDelay, killThread ) import qualified Control.Concurrent.STM as STM-import Control.Exception ( SomeException, catch )+import Control.Exception ( SomeException, catch, AsyncException(..), throwIO ) import qualified Data.HashMap.Strict as HM import Data.Int (Int64) import Data.Semigroup ( Max(..) )@@ -14,6 +14,7 @@ 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@@ -24,24 +25,45 @@ 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- logger <- mhGetIOLogger- liftIO $ do++ tid <- liftIO $ do let shunt (Left msg) = writeBChan (st^.csResources.crEventQueue) (WebsocketParseError msg) shunt (Right e) = writeBChan (st^.csResources.crEventQueue) (WSEvent e) runWS = WS.mmWithWebSocket session shunt $ \ws -> do writeBChan (st^.csResources.crEventQueue) WebsocketConnect processWebsocketActions st ws 1 HM.empty- void $ forkIO $ runWS `catch` handleTimeout logger 1 st- `catch` handleError logger 5 st+ logger LogWebsocket "Starting new websocket thread"+ forkIO $ runWS `catch` ignoreThreadKilled+ `catch` handleTimeout logger 1 st+ `catch` handleError logger 5 st --- | 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 in 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.+ 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)
src/Draw.hs view
@@ -12,6 +12,7 @@ import Draw.ShowHelp import Draw.UserListOverlay import Draw.ViewMessage+import Draw.ManageAttachments import Types @@ -31,3 +32,5 @@ PostListOverlay contents -> drawPostListOverlay contents st UserListOverlay -> drawUserListOverlay st ViewMessage -> drawViewMessage st+ ManageAttachments -> drawManageAttachments st+ ManageAttachmentsBrowseFiles -> drawManageAttachments st
+ src/Draw/Autocomplete.hs view
@@ -0,0 +1,135 @@+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 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 = "*"++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 $ _acListElementType ac <> ": " <> (T.pack $ show numResults) <>+ " match" <> if numResults == 1 then "" else "es"++ selElem = snd <$> listSelectedElement matchList+ footer = case renderAutocompleteFooterFor =<< selElem of+ Just w -> hBorderWithLabel w+ _ -> hBorder++ in if numResults == 0+ then emptyWidget+ else Widget Greedy Greedy $ do+ ctx <- getContext+ let rowOffset = ctx^.availHeightL - 3 - editorOffset - visibleHeight+ editorOffset = if st^.csEditState.cedMultiline+ then multilineHeightLimit+ else 0+ render $ translateBy (Location (0, rowOffset)) $+ vBox [ hBorderWithLabel label+ , vLimit visibleHeight $+ renderList renderAutocompleteAlternative True matchList+ , footer+ ]++renderAutocompleteFooterFor :: AutocompleteAlternative -> Maybe (Widget Name)+renderAutocompleteFooterFor (UserCompletion _ False) =+ Just $ hBox [ txt $ "("+ , withDefAttr clientEmphAttr (txt userNotInChannelMarker)+ , txt ": not in this channel)"+ ]+renderAutocompleteFooterFor (ChannelCompletion False _) =+ Just $ hBox [ txt $ "("+ , withDefAttr clientEmphAttr (txt userNotInChannelMarker)+ , txt ": not in this channel)"+ ]+renderAutocompleteFooterFor _ = Nothing++renderAutocompleteAlternative :: Bool -> AutocompleteAlternative -> Widget Name+renderAutocompleteAlternative sel (UserCompletion u inChan) =+ padRight Max $ renderUserCompletion 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++renderUserCompletion :: User -> Bool -> Bool -> Widget Name+renderUserCompletion 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 username ("@" <> username)+ , padTo fullNameWidth $ txt fullName+ , txt nickname+ ]++renderChannelCompletion :: Channel -> Bool -> Bool -> Widget Name+renderChannelCompletion c inChan selected =+ let nameWidth = 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 nameWidth $+ withDefAttr channelNameAttr $+ txt $ normalChannelSigil <> (sanitizeUserText $ channelName c)+ , txt $ sanitizeUserText $ channelHeader 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 view
@@ -23,139 +23,113 @@ import Brick import Brick.Widgets.Border-import qualified Data.Sequence as Seq-import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as HM+import Brick.Widgets.Center (hCenter) import qualified Data.Text as T-import Lens.Micro.Platform (Getting, at, non)+import Lens.Micro.Platform (at, non) +import qualified Network.Mattermost.Types as MM+ import Draw.Util import State.Channels import Themes import Types---type GroupName = Text---- | Specify the different groups of channels to be displayed--- vertically in the ChannelList sidebar. This list provides the--- central control over what channels are displayed and how they are--- grouped.------ Each group is specified as a tuple of:------ * the name of this group------ * A lens to get the HashMap of matching selections when in--- ChannelSelect mode (ignored for Normal mode).------ * The function to retrieve the list of channels for this group--- from the ChatState.------ The retrieval function is also given an optional integer that--- indicates the height of the channel list (the amount of screen space--- available to be used). This is provided as an optimization so that we--- can avoid rendering all known entries when they wouldn't be visible--- anyway. Please see 'getDmChannels' for more details.------ The height value is optional because when we're in channel selection--- mode, we don't want to optimize away hidden channel list entries. If--- we were to do that, they wouldn't be checked for matching against the--- channel selection input. So in that case 'Nothing' is given as the--- channel list height. But otherwise when we're not in that mode we--- want to skip rendering hidden entries. (Ideally we wouldn't need this--- hack at all and could be smart about which entries to show regardless--- of mode, but right now we use a Brick viewport to make scrolling the--- channel list easy, but that doesn't give us much control over which--- entries to skip.)------ Lastly, this functionality uses Sequences instead of lists to--- facilitate efficient take/drop operations when the optimization--- mentioned above is in effect.-channelListGroups :: [ ( GroupName- , Getting [ChannelSelectMatch] ChatState [ChannelSelectMatch]- , ChatState -> Maybe Int -> (ChannelListEntry -> Bool) -> Seq ChannelListEntry- , Text -> MatchValue- ) ]-channelListGroups =- [ ("Channels", csChannelSelectState.channelMatches, getOrdinaryChannels, ChannelMatch)- , ("Users", csChannelSelectState.userMatches, getDmChannels, UserMatch)- ]+import qualified Zipper as Z --- | True if there is an active channel selection operation (i.e. in--- ChannelSelect mode). This requires both the state change *and*--- some channel selection text.-hasActiveChannelSelection :: ChatState -> Bool-hasActiveChannelSelection st =- appMode st == ChannelSelect && not (T.null (st^.csChannelSelectState.channelSelectInput))+-- | 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+ , entryIsCurrent :: Bool+ , entryUserStatus :: Maybe UserStatus+ } --- | This is the main function that is called from external code to--- render the ChannelList sidebar. renderChannelList :: ChatState -> Widget Name renderChannelList st =- Widget Fixed Greedy $ do- ctx <- getContext-- let selMatch = st^.csChannelSelectState.selectedMatch- renderedGroups gs =- if hasActiveChannelSelection st- then let (n, es, mkMatchValue) = selectedGroupEntries gs- in renderChannelGroup (renderChannelSelectListEntry selMatch mkMatchValue) (n, es)- else renderChannelGroup renderChannelListEntry $ plainGroupEntries gs- plainGroupEntries (n, _, f, _) =- (n, f st (Just $ ctx^.availHeightL) (const True))- selectedGroupEntries (n, m, f, mkMatchValue) =- let mapping = HM.fromList $ (\match -> (matchFull match, match)) <$> matches- matches = st^.m- in ( n- , F.foldr (addSelectedChannel mapping) mempty $- f st (Just $ ctx^.availHeightL) (hasChannelSelectMatch mapping)- , mkMatchValue- )- hasChannelSelectMatch matches e =- HM.member (entryLabel e) matches- addSelectedChannel matches e s =- case HM.lookup (entryLabel e) matches of- Just y -> SCLE e y Seq.<| s- Nothing -> s-- render $ viewport ChannelList Vertical $- vBox $ vBox <$>- toList <$> (toList $ renderedGroups <$> channelListGroups)+ viewport ChannelList Vertical body+ where+ body = case appMode st of+ ChannelSelect ->+ let zipper = st^.csChannelSelectState.channelSelectMatches+ in if Z.isEmpty zipper+ then hCenter $ txt "No matches"+ else vBox $+ renderChannelListGroup st (renderChannelSelectListEntry (Z.focus zipper)) <$>+ Z.toList zipper+ _ ->+ cached ChannelSidebar $+ vBox $+ renderChannelListGroup st (\s e -> renderChannelListEntry $ mkChannelEntryData s e) <$>+ Z.toList (st^.csFocus) --- | Renders a specific group, given the name of the group and the--- list of entries in that group (which are expected to be either--- ChannelListEntry or SelectedChannelListEntry elements).-renderChannelGroup :: (a -> Widget Name) -> (GroupName, Seq a) -> Seq (Widget Name)-renderChannelGroup eRender (groupName, entries) =- let header label = hBorderWithLabel $- withDefAttr channelListHeaderAttr $ txt label- in header groupName Seq.<| (eRender <$> entries)+renderChannelListGroupHeading :: ChannelListGroup -> Bool -> Widget Name+renderChannelListGroupHeading g anyUnread =+ let label = case g of+ ChannelGroupPublicChannels -> "Public Channels"+ ChannelGroupDirectMessages -> "Direct Messages"+ addUnread = if anyUnread+ then (<+> (withDefAttr unreadGroupMarkerAttr $ txt "*"))+ else id+ labelWidget = addUnread $ withDefAttr channelListHeaderAttr $ txt label+ in hBorderWithLabel labelWidget --- | 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 ChannelListEntry =- ChannelListEntry { entrySigil :: Text- , entryLabel :: Text- , entryHasUnread :: Bool- , entryMentions :: Int- , entryIsRecent :: Bool- , entryIsCurrent :: Bool- , entryUserStatus :: Maybe UserStatus- }+renderChannelListGroup :: ChatState+ -> (ChatState -> e -> (Bool, Widget Name))+ -> (ChannelListGroup, [e])+ -> Widget Name+renderChannelListGroup st renderEntry (group, es) =+ let heading = renderChannelListGroupHeading group anyUnread+ entryResults = renderEntry st <$> es+ (unreadFlags, entryWidgets) = unzip entryResults+ anyUnread = or unreadFlags+ in if null entryWidgets+ then emptyWidget+ else vBox (heading : entryWidgets) --- | Similar to the ChannelListEntry, but also holds information about--- the matching channel select specification.-data SelectedChannelListEntry = SCLE ChannelListEntry ChannelSelectMatch+mkChannelEntryData :: ChatState+ -> ChannelListEntry+ -> ChannelListEntryData+mkChannelEntryData st e =+ ChannelListEntryData sigilWithSpace name unread mentions recent current status+ where+ cId = channelListEntryChannelId e+ Just chan = findChannelById cId (st^.csChannels)+ unread = hasUnread' chan+ recent = isRecentChannel st cId+ 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)+ CLGroupDM _ ->+ (chan^.ccInfo.cdName, 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 ""+ sigil = case st^.csEditState.cedLastChannelInput.at cId of+ Nothing -> fromMaybe "" normalSigil+ Just ("", _) -> fromMaybe "" normalSigil+ _ -> "»"+ mentions = chan^.ccInfo.cdMentionCount -- | Render an individual Channel List entry (in Normal mode) with -- appropriate visual decorations.-renderChannelListEntry :: ChannelListEntry -> Widget Name-renderChannelListEntry entry =- decorate $ decorateRecent entry $ decorateMentions $ padRight Max $- entryWidget $ entrySigil entry <> entryLabel entry+renderChannelListEntry :: ChannelListEntryData -> (Bool, Widget Name)+renderChannelListEntry entry = (entryHasUnread entry, body) where+ body = decorate $ decorateRecent entry $ decorateMentions $ padRight Max $+ entryWidget $ entrySigil entry <> entryLabel entry decorate = if | entryIsCurrent entry -> visible . forceAttr currentChannelNameAttr | entryMentions entry > 0 ->@@ -174,91 +148,27 @@ (<+> str ("(" <> show (entryMentions entry) <> ")")) | 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 MatchValue -> (Text -> MatchValue) -> SelectedChannelListEntry -> Widget Name-renderChannelSelectListEntry selMatch mkMatchValue (SCLE entry match) =- let ChannelSelectMatch preMatch inMatch postMatch fullName = match- maybeSelect = if Just (mkMatchValue fullName) == selMatch+renderChannelSelectListEntry :: Maybe ChannelSelectMatch -> ChatState -> ChannelSelectMatch -> (Bool, 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- in maybeSelect $- decorateRecent entry $- padRight Max $- hBox [ txt $ entrySigil entry- , txt preMatch- , forceAttr channelSelectMatchAttr $ txt inMatch- , txt postMatch- ]+ entryData = mkChannelEntryData st entry+ in (False, maybeSelect $+ decorateRecent entryData $+ padRight Max $+ hBox [ txt $ entrySigil entryData <> preMatch+ , forceAttr channelSelectMatchAttr $ txt inMatch+ , txt postMatch+ ]) -- | If this channel is the most recently viewed channel (prior to the -- currently viewed channel), add a decoration to denote that.-decorateRecent :: ChannelListEntry -> Widget n -> Widget n+decorateRecent :: ChannelListEntryData -> Widget n -> Widget n decorateRecent entry = if entryIsRecent entry then (<+> (withDefAttr recentMarkerAttr $ str "<")) else id---- | Extract the names and information about normal channels to be--- displayed in the ChannelList sidebar.-getOrdinaryChannels :: ChatState -> Maybe Int -> (ChannelListEntry -> Bool) -> Seq ChannelListEntry-getOrdinaryChannels st _ _ =- Seq.fromList [ ChannelListEntry sigil n unread mentions recent current Nothing- | n <- allChannelNames st- , let Just chan = channelIdByChannelName n st- unread = hasUnread st chan- recent = isRecentChannel st chan- current = isCurrentChannel st chan- sigil = case st ^. csEditState.cedLastChannelInput.at chan of- Nothing -> normalChannelSigil- Just ("", _) -> normalChannelSigil- _ -> "»"- mentions = channelMentionCount chan st- ]---- | Extract the names and information about Direct Message channels--- to be displayed in the ChannelList sidebar.------ This function takes advantage of the channel height, when given, by--- only returning enough entries to guarantee that we fill the channel--- list. For example, if the list is N rows high, this function will--- return at most 2N channel list entries. It does this, rather than--- return them all, to avoid rendering (potentially thousands of)--- entries that won't be visible on the screen anyway, and that turns--- out to be a big performance win on servers with thousands of users.--- We return *twice* the number of required entries to ensure that no--- matter where the selected channel is within the set of returned--- entries, there are enough entries before and after the selected--- channel to get the Brick viewport to position the final result in a--- way that is natural.-getDmChannels :: ChatState -> Maybe Int -> (ChannelListEntry -> Bool) -> Seq ChannelListEntry-getDmChannels st height matches =- let es = Seq.filter matches $- Seq.fromList- [ ChannelListEntry (T.cons sigil " ") uname unread- mentions recent current (Just $ u^.uiStatus)- | u <- sortedUserList st- , let sigil =- case do { cId <- m_chanId; st^.csEditState.cedLastChannelInput.at cId } of- Nothing -> userSigilFromInfo u- Just ("", _) -> userSigilFromInfo u- _ -> '»' -- shows that user has a message in-progress- uname = if useNickname st- then u^.uiNickName.non (u^.uiName)- else u^.uiName- recent = maybe False (isRecentChannel st) m_chanId- m_chanId = channelIdByUsername (u^.uiName) st- unread = maybe False (hasUnread st) m_chanId- current = case appMode st of- ChannelSelect -> Just (UserMatch uname) == st^.csChannelSelectState.selectedMatch- _ -> maybe False (isCurrentChannel st) m_chanId- mentions = fromMaybe 0 $ channelMentionCount <$> m_chanId <*> pure st- ]- (h, t) = Seq.breakl entryIsCurrent es- in case height of- Nothing -> es- Just height' -> if null t- then Seq.take height' h- else Seq.drop (length h - height') h <>- Seq.take height' t
src/Draw/Main.hs view
@@ -8,13 +8,11 @@ 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 Brick.Widgets.List ( renderList ) import Control.Arrow ( (>>>) ) import Control.Monad.Trans.Reader ( withReaderT ) import Data.Char ( isSpace, isPunctuation )-import qualified Data.Foldable as F-import Data.List ( intersperse ) import qualified Data.Sequence as Seq import qualified Data.Set as S import qualified Data.Text as T@@ -25,13 +23,15 @@ import Lens.Micro.Platform ( (.~), (^?!), to, view, folding ) import Network.Mattermost.Types ( ChannelId, Type(Direct, Private, Group)- , ServerTime(..), UserId )+ , ServerTime(..), UserId+ ) -import Completion ( Completer(..), CompletionAlternative(..), currentAlternative ) import Constants import Draw.ChannelList ( renderChannelList ) import Draw.Messages+import Draw.Autocomplete+import Draw.URLList import Draw.Util import Events.Keybindings import Events.MessageSelect@@ -41,7 +41,6 @@ import TimeUtils ( justAfter, justBefore ) import Types import Types.KeyEvents-import Types.Messages ( msgURLs ) previewFromInput :: Maybe MessageType -> UserId -> Text -> Maybe Message@@ -270,13 +269,12 @@ , showCursor MessageInput (Location (0,0)) $ str " " ] else [inputBox]- True -> vLimit 5 inputBox <=> multilineHints+ True -> vLimit multilineHeightLimit inputBox <=> multilineHints in replyDisplay <=> commandBox renderChannelHeader :: ChatState -> HighlightSet -> ClientChannel -> Widget Name renderChannelHeader st hs chan = let chnType = chan^.ccInfo.cdType- chnName = chan^.ccInfo.cdName topicStr = chan^.ccInfo.cdHeader userHeader u = let s = T.intercalate " " $ filter (not . T.null) parts parts = [ userSigil <> u^.uiName@@ -295,15 +293,14 @@ quote n = "\"" <> n <> "\"" nick = maybe "" quote $ u^.uiNickName in s- foundUser = userByDMChannelName chnName (myUserId st) st maybeTopic = if T.null topicStr then "" else " - " <> topicStr channelNameString = case chnType of Direct ->- case foundUser of+ case chan^.ccInfo.cdDMUserId >>= flip userById st of Nothing -> mkChannelName (chan^.ccInfo)- Just u -> userHeader u+ Just u -> userHeader u Private -> mkChannelName (chan^.ccInfo) <> " (Private)" Group ->@@ -343,7 +340,9 @@ renderMessagesWithSelect (st^.csMessageSelect) channelMessages MessageSelectDeleteConfirm -> renderMessagesWithSelect (st^.csMessageSelect) channelMessages- _ -> renderLastMessages $ reverseMessages channelMessages+ _ ->+ cached (ChannelMessages cId) $+ renderLastMessages $ reverseMessages channelMessages renderMessagesWithSelect (MessageSelectState selMsgId) msgs = -- In this case, we want to fill the message list with messages@@ -426,18 +425,15 @@ renderChannelSelectPrompt :: ChatState -> Widget Name renderChannelSelectPrompt st =- let cstr = st^.csChannelSelectState.channelSelectInput+ let e = st^.csChannelSelectState.channelSelectInput in withDefAttr channelSelectPromptAttr $ (txt "Switch to channel [use ^ and $ to anchor]: ") <+>- (showCursor ChannelSelectString (Location (T.length cstr, 0)) $- txt $- (if T.null cstr- then " "- else cstr))+ (renderEditor (txt . T.concat) True e) drawMain :: ChatState -> [Widget Name] drawMain st = [ connectionLayer st+ , autocompleteLayer st , joinBorders $ mainInterface st ] @@ -517,22 +513,6 @@ , hBorder ] -drawCompletionAlternatives :: Completer -> Widget Name-drawCompletionAlternatives c =- let alternatives = intersperse (txt " ") $ mkAlternative <$> toList (completionAlternatives c)- mkAlternative alt =- let format = if completionInput alt == (completionInput $ currentAlternative c)- then visible . withDefAttr completionAlternativeCurrentAttr- else id- in format $ txt $ completionDisplay alt- in hBox [ borderElem bsHorizontal- , txt "["- , withDefAttr completionAlternativeListAttr $- vLimit 1 $ viewport CompletionAlternatives Horizontal $ hBox alternatives- , txt "]"- , borderElem bsHorizontal- ]- maybePreviewViewport :: Widget Name -> Widget Name maybePreviewViewport w = Widget Greedy Fixed $ do@@ -623,14 +603,23 @@ bottomBorder = case appMode st of MessageSelect -> messageSelectBottomBar st- _ -> case st^.csEditState.cedCompleter of- Just c -> drawCompletionAlternatives c- _ -> maybeSubdue $ hBox- [ hBorder- , showTypingUsers- , showBusy- ]+ _ -> 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") <> ")"+ ]+ showTypingUsers = case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of [] -> emptyWidget [uId] | Just un <- usernameForUserId uId st ->@@ -648,35 +637,3 @@ maybeSubdue = if appMode st == ChannelSelect then forceAttr "" else id--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-- renderItem sel link =- let time = link^.linkTime- in attr sel $ vLimit 2 $- (vLimit 1 $- hBox [ let u = maybe "" id (link^.linkUser.to (nameForUserRef st)) in colorUsername u u- , if link^.linkName == link^.linkURL- then emptyWidget- else (txt ": " <+> (renderText $ link^.linkName))- , fill ' '- , renderDate st $ withServerTime time- , str " "- , renderTime st $ withServerTime time- ] ) <=>- (vLimit 1 (renderText $ link^.linkURL))-- attr True = forceAttr "urlListSelectedAttr"- attr False = id
+ src/Draw/ManageAttachments.hs view
@@ -0,0 +1,61 @@+module Draw.ManageAttachments+ ( drawManageAttachments+ )+where++import Prelude ()+import Prelude.MH++import Brick+import Brick.Widgets.List+import Brick.Widgets.Center+import Brick.Widgets.Border+import qualified Brick.Widgets.FileBrowser as FB++import Types+import Types.KeyEvents+import Events.Keybindings ( getFirstDefaultBinding )+import Themes+import Draw.Main ( drawMain )+++drawManageAttachments :: ChatState -> [Widget Name]+drawManageAttachments st =+ topLayer : drawMain 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 (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 (txt "Attach File") $+ FB.renderFileBrowser True (st^.csEditState.cedFileBrowser)
src/Draw/Messages.hs view
@@ -33,7 +33,7 @@ nameForUserRef st uref = case uref of NoUser -> Nothing UserOverride t -> Just t- UserI uId -> displaynameForUserId uId st+ UserI uId -> displayNameForUserId uId st -- | renderSingleMessage is the main message drawing function. --
src/Draw/PostListOverlay.hs view
@@ -83,9 +83,7 @@ | Just chan <- st^?csChannels.channelByIdL(post^.postChannelIdL) -> case chan^.ccInfo.cdType of Direct- | Just u <- userByDMChannelName (chan^.ccInfo.cdName)- (myUserId st)- st ->+ | Just u <- flip userById st =<< chan^.ccInfo.cdDMUserId -> (forceAttr channelNameAttr (txt (userSigil <> u^.uiName)) <=> (str " " <+> renderedMsg)) _ -> (forceAttr channelNameAttr (txt (chan^.ccInfo.to mkChannelName)) <=>
src/Draw/ShowHelp.hs view
@@ -6,7 +6,7 @@ import Brick import Brick.Themes ( themeDescriptions ) import Brick.Widgets.Border-import Brick.Widgets.Center ( hCenter, centerLayer )+import Brick.Widgets.Center ( hCenter ) import Brick.Widgets.List ( listSelectedFocusedAttr ) import qualified Data.Map as M import qualified Data.Text as T@@ -24,6 +24,7 @@ import Events.ShowHelp import Events.UrlSelect import Events.UserListOverlay+import Events.ManageAttachments import Events.ViewMessage import HelpTopics ( helpTopics ) import Markdown ( renderText )@@ -338,14 +339,6 @@ attrNameToConfig :: AttrName -> Text attrNameToConfig = T.pack . intercalate "." . attrNameComponents -withMargins :: (Int, Int) -> Widget a -> Widget a-withMargins (hMargin, vMargin) w =- Widget (hSize w) (vSize w) $ do- ctx <- getContext- let wl = ctx^.availWidthL - (2 * hMargin)- hl = ctx^.availHeightL - (2 * vMargin)- render $ hLimit wl $ vLimit hl w- keybindSections :: KeyConfig -> [(Text, [Keybinding])] keybindSections kc = [ ("This Help Page", helpKeybindings kc)@@ -358,16 +351,15 @@ , ("Flagged Messages", postListOverlayKeybindings kc) , ("User Listings", userListOverlayKeybindings kc) , ("Message Viewer", viewMessageKeybindings kc)+ , ("Attachment List", attachmentListKeybindings kc) ] helpBox :: Name -> Widget Name -> Widget Name helpBox n helpText =- centerLayer $ withMargins (2, 1) $- (withDefAttr helpAttr $ borderWithLabel (withDefAttr helpEmphAttr $ txt "Matterhorn Help") $- (viewport HelpViewport Vertical $ cached n helpText)) <=>- quitMessage- where- quitMessage = padTop (Pad 1) $ hCenter $ txt "Press Esc to exit the help screen."+ withDefAttr helpAttr $+ borderWithLabel (withDefAttr helpEmphAttr $ txt "Matterhorn Help") $+ viewport HelpViewport Vertical $+ cached n helpText kbColumnWidth :: Int kbColumnWidth = 12
+ src/Draw/URLList.hs view
@@ -0,0 +1,53 @@+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 Markdown+import Themes+import Types+++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++ renderItem sel link =+ let time = link^.linkTime+ in attr sel $ vLimit 2 $+ (vLimit 1 $+ hBox [ let u = maybe "" id (link^.linkUser.to (nameForUserRef st)) in colorUsername u u+ , if link^.linkName == link^.linkURL+ then emptyWidget+ else (txt ": " <+> (renderText $ link^.linkName))+ , fill ' '+ , renderDate st $ withServerTime time+ , str " "+ , renderTime st $ withServerTime time+ ] ) <=>+ (vLimit 1 (renderText $ link^.linkURL))++ attr True = forceAttr "urlListSelectedAttr"+ attr False = id
src/Draw/UserListOverlay.hs view
@@ -71,9 +71,10 @@ scope = st^.userListSearchScope promptMsg = case scope of- ChannelMembers _ -> "Search channel members:"- ChannelNonMembers _ -> "Search users:"- AllUsers -> "Search users:"+ ChannelMembers _ _ -> "Search channel members:"+ ChannelNonMembers _ _ -> "Search users:"+ AllUsers Nothing -> "Search users:"+ AllUsers (Just _) -> "Search team members:" userResultList = if st^.userListSearching@@ -85,15 +86,16 @@ showResults | numSearchResults == 0 = showMessage $ case scope of- ChannelMembers _ -> "No users in channel."- ChannelNonMembers _ -> "All users in your team are already in this channel."- AllUsers -> "No users found."+ ChannelMembers _ _ -> "No users in channel."+ ChannelNonMembers _ _ -> "All users in your team are already in this channel."+ AllUsers _ -> "No users found." | otherwise = renderedUserList contentHeader = str $ case scope of- ChannelMembers _ -> "Channel Members"- ChannelNonMembers _ -> "Invite Users to Channel"- AllUsers -> "Users On This Server"+ ChannelMembers _ _ -> "Channel Members"+ ChannelNonMembers _ _ -> "Invite Users to Channel"+ AllUsers Nothing -> "Users On This Server"+ AllUsers (Just _) -> "Users In My Team" renderedUserList = L.renderList renderUser True (st^.userListSearchResults) numSearchResults = F.length $ st^.userListSearchResults.L.listElementsL
src/Draw/Util.hs view
@@ -1,4 +1,14 @@-module Draw.Util where+module Draw.Util+ ( withBrackets+ , renderTime+ , renderDate+ , insertDateMarkers+ , getDateFormat+ , mkChannelName+ , userSigilFromInfo+ , multilineHeightLimit+ )+where import Prelude () import Prelude.MH@@ -20,6 +30,9 @@ defaultDateFormat :: Text defaultDateFormat = "%Y-%m-%d" +multilineHeightLimit :: Int+multilineHeightLimit = 5+ getTimeFormat :: ChatState -> Text getTimeFormat st = maybe defaultTimeFormat id (st^.csResources.crConfiguration.to configTimeFormat)@@ -75,6 +88,3 @@ Group -> mempty Direct -> userSigil Unknown _ -> mempty--mkDMChannelName :: UserInfo -> Text-mkDMChannelName u = T.cons (userSigilFromInfo u) (u^.uiName)
src/Events.hs view
@@ -1,16 +1,17 @@-{-# LANGUAGE MultiWayIf #-}-module Events where+module Events+ ( onEvent+ )+where import Prelude () import Prelude.MH import Brick-import qualified Data.Map as M 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 ( (.=) )+import Lens.Micro.Platform ( (.=), preuse ) import qualified Network.Mattermost.Endpoints as MM import Network.Mattermost.Exceptions ( mattermostErrorMessage )@@ -28,13 +29,11 @@ import State.Users import Types import Types.Common-import Types.KeyEvents import Events.ChannelScroll import Events.ChannelSelect import Events.DeleteChannelConfirm import Events.JoinChannel-import Events.Keybindings import Events.LeaveChannelConfirm import Events.Main import Events.MessageSelect@@ -43,42 +42,52 @@ import Events.UrlSelect import Events.UserListOverlay import Events.ViewMessage+import Events.ManageAttachments onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState)-onEvent st ev = runMHEvent st (onEv >> fetchVisibleIfNeeded)- where onEv = do case ev of- (AppEvent e) -> onAppEvent e- (VtyEvent (Vty.EvKey (Vty.KChar 'l') [Vty.MCtrl])) -> do- vty <- mh getVtyHandle- liftIO $ Vty.refresh vty- (VtyEvent e) -> onVtyEvent e- _ -> return ()+onEvent st ev = runMHEvent st $ onBrickEvent ev +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 RefreshWebsocketEvent =+ connectWebsockets onAppEvent WebsocketDisconnect = do- csConnectionStatus .= Disconnected- disconnectChannels+ csConnectionStatus .= Disconnected+ disconnectChannels onAppEvent WebsocketConnect = do- csConnectionStatus .= Connected- refreshChannelsAndUsers- refreshClientConfig-onAppEvent BGIdle = csWorkerIsBusy .= Nothing-onAppEvent (BGBusy n) = csWorkerIsBusy .= Just n+ csConnectionStatus .= Connected+ refreshChannelsAndUsers+ refreshClientConfig+ fetchVisibleIfNeeded+onAppEvent BGIdle =+ csWorkerIsBusy .= Nothing+onAppEvent (BGBusy n) =+ csWorkerIsBusy .= Just n onAppEvent (WSEvent we) =- handleWSEvent we+ handleWSEvent we 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+ 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 e handleIEvent :: InternalEvent -> MH ()-handleIEvent (DisplayError e) = postErrorMessage' $ formatError e+handleIEvent (DisplayError e) =+ postErrorMessage' $ formatError e handleIEvent (LoggingStarted path) = postInfoMessage $ "Logging to " <> T.pack path handleIEvent (LogDestination dest) =@@ -131,11 +140,16 @@ onVtyEvent :: Vty.Event -> MH () onVtyEvent e = do- -- Even if we aren't showing the help UI when a resize occurs, we- -- need to invalidate its cache entry anyway in case the new size- -- differs from the cached size. case e of- (Vty.EvResize _ _) -> mh invalidateCache+ (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 () mode <- gets appMode@@ -153,6 +167,8 @@ PostListOverlay _ -> onEventPostListOverlay e UserListOverlay -> onEventUserListOverlay e ViewMessage -> onEventViewMessage e+ ManageAttachments -> onEventManageAttachments e+ ManageAttachmentsBrowseFiles -> onEventManageAttachments e handleWSEvent :: WebsocketEvent -> MH () handleWSEvent we = do@@ -163,20 +179,29 @@ | Just p <- wepPost (weData we) -> when (wepTeamId (weData we) == Just myTId || wepTeamId (weData we) == Nothing) $ do- -- If the message is a header change, also update- -- the channel metadata.- let wasMentioned = case wepMentions (weData we) of- Just lst -> myId `Set.member` lst- _ -> False+ 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) -> editMessage p+ | 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) -> deleteMessage p+ | 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@@ -193,7 +218,8 @@ | otherwise -> return () WMNewUser- | Just uId <- wepUserId $ weData we -> handleNewUsers (Seq.singleton uId)+ | Just uId <- wepUserId $ weData we ->+ handleNewUsers (Seq.singleton uId) (return ()) | otherwise -> return () WMUserRemoved@@ -254,8 +280,11 @@ | otherwise -> return () WMChannelUpdated- | Just cId <- webChannelId $ weBroadcast we ->- when (webTeamId (weBroadcast we) == Just myTId) $ refreshChannelById cId+ | Just cId <- webChannelId $ weBroadcast we -> do+ mChan <- preuse (csChannel(cId))+ when (isJust mChan) $ do+ refreshChannelById cId+ updateSidebar | otherwise -> return () WMGroupAdded@@ -283,112 +312,6 @@ WMPluginEnabled -> return () WMPluginDisabled -> return () --- | 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 -> Either String ()-ensureKeybindingConsistency kc = 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\n"- , "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 ev =- let bindingHasEvent (KB _ _ _ (Just ev')) = ev == ev'- bindingHasEvent _ = False- in [ mode- | (mode, bindings) <- modeMaps- , any bindingHasEvent bindings- ]-- modeMaps = [ ("main" :: String, mainKeybindings kc)- , ("help screen", helpKeybindings kc)- , ("channel select", channelSelectKeybindings kc)- , ("url select", urlSelectKeybindings kc)- , ("channel scroll", channelScrollKeybindings kc)- , ("message select", messageSelectKeybindings kc)- , ("post list overlay", postListOverlayKeybindings kc)- ]- -- | Refresh client-accessible server configuration information. This -- is usually triggered when a reconnect event for the WebSocket to the -- server occurs.@@ -397,4 +320,6 @@ session <- getSession doAsyncWith Preempt $ do cfg <- MM.mmGetClientConfiguration (Just "old") session- return (csClientConfig .= Just cfg)+ return $ Just $ do+ csClientConfig .= Just cfg+ updateSidebar
src/Events/ChannelScroll.hs view
@@ -26,8 +26,10 @@ channelPageUp , mkKb PageDownEvent "Scroll down" channelPageDown- , mkKb CancelEvent "Cancel scrolling and return to channel view" $- setMode Main+ , mkKb CancelEvent "Cancel scrolling and return to channel view" $ do+ cId <- use csCurrentChannelId+ mh $ invalidateCacheEntry (ChannelMessages cId)+ setMode Main , mkKb ScrollTopEvent "Scroll to top" channelScrollToTop , mkKb ScrollBottomEvent "Scroll to bottom"
src/Events/ChannelSelect.hs view
@@ -3,38 +3,32 @@ import Prelude () import Prelude.MH -import qualified Data.Text as T+import Brick.Widgets.Edit ( handleEditorEvent ) import qualified Graphics.Vty as Vty-import Lens.Micro.Platform ( (%=) ) import Events.Keybindings import State.Channels import State.ChannelSelect import Types+import qualified Zipper as Z onEventChannelSelect :: Vty.Event -> MH () onEventChannelSelect =- handleKeyboardEvent channelSelectKeybindings $ \ e -> case e of- (Vty.EvKey Vty.KBS []) -> do- csChannelSelectState.channelSelectInput %= (\s -> if T.null s then s else T.init s)- updateChannelSelectMatches- (Vty.EvKey (Vty.KChar c) []) | c /= '\t' -> do- csChannelSelectState.channelSelectInput %= (flip T.snoc c)+ handleKeyboardEvent channelSelectKeybindings $ \e -> do+ mhHandleEventLensed (csChannelSelectState.channelSelectInput) handleEditorEvent e updateChannelSelectMatches- _ -> return () channelSelectKeybindings :: KeyConfig -> [Keybinding] channelSelectKeybindings = mkKeybindings [ staticKb "Switch to selected channel" (Vty.EvKey Vty.KEnter []) $ do- selMatch <- use (csChannelSelectState.selectedMatch)-- setMode Main-- let switch (UserMatch m) = changeChannel (userSigil <> m)- switch (ChannelMatch m) = changeChannel (normalChannelSigil <> m)- maybe (return ()) switch selMatch+ 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
src/Events/Keybindings.hs view
@@ -18,12 +18,14 @@ , 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 @@ -102,6 +104,7 @@ 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') ]@@ -143,3 +146,104 @@ EditMessageEvent -> [ key 'e' ] ReplyMessageEvent -> [ key 'r' ] OpenMessageURLEvent -> [ key 'o' ]++ AttachmentListAddEvent -> [ key 'a' ]+ AttachmentListDeleteEvent -> [ key 'd' ]+ AttachmentOpenEvent -> [ key 'o' ]++-- | 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.+ 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\n"+ , "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 ev =+ let bindingHasEvent (KB _ _ _ (Just ev')) = ev == ev'+ bindingHasEvent _ = False+ in [ mode+ | (mode, mkBindings) <- modeMaps+ , any bindingHasEvent (mkBindings kc)+ ]
src/Events/Main.hs view
@@ -6,23 +6,21 @@ import Brick hiding ( Direction ) import Brick.Widgets.Edit-import qualified Data.Map as M-import qualified Data.Set as Set+import qualified Brick.Widgets.List as L+import Data.Char ( isSpace )+import qualified Data.Foldable as F import qualified Data.Text as T import qualified Data.Text.Zipper as Z import qualified Data.Text.Zipper.Generic.Words as Z import qualified Graphics.Vty as Vty-import Lens.Micro.Platform ( (%=), (.=), to, at )-import qualified Skylighting.Types as Sky--import Network.Mattermost.Types ( Type(..) )+import Lens.Micro.Platform ( (%=), (.=), to, at, _Just ) import Command-import Completion import Constants import Events.Keybindings import HelpTopics ( mainHelpTopic ) import InputHistory+import State.Attachments import State.Help import State.Channels import State.ChannelSelect@@ -122,7 +120,11 @@ , mkKb NextUnreadChannelEvent "Change to the next channel with unread messages" nextUnreadChannel - , mkKb NextUnreadUserOrChannelEvent "Change to the next channel with unread messages preferring direct messages"+ , 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"@@ -132,27 +134,23 @@ (Vty.EvKey Vty.KEnter []) $ do isMultiline <- use (csEditState.cedMultiline) case isMultiline of- -- Enter in multiline mode does the usual thing; we- -- only send on Enter when we're outside of multiline- -- mode.- True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent- (Vty.EvKey Vty.KEnter [])- False -> do- csEditState.cedCompleter .= Nothing- handleInputSubmission+ -- 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 -> handleInputSubmission , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel" startUrlSelect , mkKb ClearUnreadEvent "Clear the current channel's unread / edited indicators" $- csCurrentChannel %= (clearNewMessageIndicator .- clearEditedThreshold)+ clearChannelUnreadStatus =<< use csCurrentChannelId , mkKb ToggleMultiLineEvent "Toggle multi-line message compose mode" toggleMultilineEditing - , mkKb CancelEvent "Cancel message reply or update"- cancelReplyOrEdit+ , mkKb CancelEvent "Cancel autocomplete, message reply, or edit, in that order"+ cancelAutocompleteOrReplyOrEdit , mkKb EnterFlaggedPostsEvent "View currently flagged posts" enterFlaggedPostListMode@@ -171,98 +169,58 @@ -- 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 allLines cId+ csEditState.cedEditor %= applyEdit Z.clearZipper+ csEditState.cedInputHistory %= addHistoryEntry allLines cId csEditState.cedInputHistoryPosition.at cId .= Nothing case T.uncons allLines of- Just ('/', cmd) -> dispatchCommand cmd- _ -> sendMessage mode allLines+ Just ('/', cmd) ->+ dispatchCommand cmd+ _ -> do+ attachments <- use (csEditState.cedAttachmentList.L.listElementsL)+ sendMessage mode allLines $ 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+ csEditState.cedEditMode .= NewPost data Direction = Forwards | Backwards tabComplete :: Direction -> MH () tabComplete dir = do- st <- use id- allUIds <- gets allUserIds- allChanNames <- gets allChannelNames- displayNick <- use (to useNickname)-- let channelCompletions = concat $ catMaybes (flip map allChanNames $ \cname -> do- -- Only permit completion of channel names for non-Group channels- ch <- channelByName cname st- case ch^.ccInfo.cdType of- Group -> Nothing- Private -> Nothing- _ -> Just [ CompletionAlternative cname (normalChannelSigil <> cname) cname- , mkAlt $ normalChannelSigil <> cname- ]- )-- userCompletions = concat $ catMaybes (flip map allUIds $ \uId ->- -- Only permit completion of user names for non-deleted users- case userById uId st of- Nothing -> Nothing- Just u | u^.uiDeleted -> Nothing- Just u ->- let mNick = case u^.uiNickName of- Just nick | displayNick ->- [ CompletionAlternative (userSigil <> nick) (userSigil <> u^.uiName) (userSigil <> nick)- , CompletionAlternative nick (userSigil <> u^.uiName) nick- ]- _ -> []- in Just $ [ CompletionAlternative (u^.uiName) (userSigil <> u^.uiName) (u^.uiName)- , mkAlt $ userSigil <> u^.uiName- ] <> mNick- )-- commandCompletions = mkAlt <$> map ("/" <>) (commandName <$> commandList)- mkAlt a = CompletionAlternative a a a- completions = Set.fromList (userCompletions ++- channelCompletions ++- commandCompletions)-- mCompleter <- use (csEditState.cedCompleter)- case mCompleter of- Just _ -> do- -- Since there is already a completion in progress, cycle it- -- according to the directional preference.- let func = case dir of- Forwards -> nextCompletion- Backwards -> previousCompletion- csEditState.cedCompleter %= fmap func- Nothing -> do- -- There is no completion in progress, so start a new- -- completion from the current input.- let line = Z.currentLine $ st^.csEditState.cedEditor.editContentsL- completionsToUse =- if | "```" `T.isPrefixOf` line ->- Set.fromList $ (\k -> (CompletionAlternative ("```" <> k) ("```" <> k) k)) <$>- (Sky.sShortname <$> (M.elems $ st^.csResources.crSyntaxMap))- | otherwise -> completions- case wordComplete completionsToUse line of- Nothing ->- -- No matches were found, so do nothing.- return ()- Just (Left single) ->- -- Only a single match was found, so just replace the- -- current word with the only match.- csEditState.cedEditor %= applyEdit (Z.insertMany single . Z.deletePrevWord)- Just (Right many) -> do- -- More than one match was found, so start a- -- completion by storing the completer state.- csEditState.cedCompleter .= Just many+ 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 - -- Get the current completer state (potentially just cycled to- -- the next completion above) and update the editor with the current- -- alternative.- mComp <- use (csEditState.cedCompleter)- case mComp of- Nothing -> return ()- Just comp -> do- let replacement = completionReplacement $ currentAlternative comp- csEditState.cedEditor %= applyEdit (Z.insertMany replacement . Z.deletePrevWord)+ mac <- use (csEditState.cedAutocomplete)+ case mac of+ Nothing -> return ()+ 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.insertMany replacement . Z.deletePrevWord .+ maybeEndOfWord)
+ src/Events/ManageAttachments.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Events.ManageAttachments+ ( onEventManageAttachments+ , attachmentListKeybindings+ , attachmentBrowseKeybindings+ )+where++import Prelude ()+import Prelude.MH++import qualified Control.Exception as E+import Control.Monad ( void )+import qualified Brick.Widgets.FileBrowser as FB+import qualified Brick.Widgets.List as L+import qualified Data.ByteString as BS+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 -> onEventAttachmentList e+ ManageAttachmentsBrowseFiles -> onEventBrowseFile e+ _ -> error "BUG: onEventManageAttachments called in invalid mode"++onEventAttachmentList :: V.Event -> MH ()+onEventAttachmentList =+ handleKeyboardEvent attachmentListKeybindings $+ mhHandleEventLensed (csEditState.cedAttachmentList) L.handleListEvent++attachmentListKeybindings :: KeyConfig -> [Keybinding]+attachmentListKeybindings = mkKeybindings+ [ mkKb CancelEvent "Close attachment list"+ (setMode Main)+ , 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 -> [Keybinding]+attachmentBrowseKeybindings = mkKeybindings+ [ mkKb CancelEvent "Cancel attachment file browse"+ cancelAttachmentBrowse+ , mkKb AttachmentOpenEvent "Open the selected file using the URL open command"+ openSelectedBrowserEntry+ ]++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 = do+ b <- use (csEditState.cedFileBrowser)+ case FB.fileBrowserCursor b of+ Nothing -> return ()+ Just entry -> void $ openURL (OpenLocalFile $ FB.fileInfoFilePath entry)++onEventBrowseFile :: V.Event -> MH ()+onEventBrowseFile e = do+ b <- use (csEditState.cedFileBrowser)+ case FB.fileBrowserIsSearching b of+ False ->+ handleKeyboardEvent attachmentBrowseKeybindings handleFileBrowserEvent e+ True ->+ handleFileBrowserEvent e++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+ mhHandleEventLensed (csEditState.cedFileBrowser) FB.handleFileBrowserEvent e+ b <- use (csEditState.cedFileBrowser)+ -- TODO: Check file browser exception state+ case FB.fileBrowserSelection b of+ Nothing -> return ()+ Just 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+ setMode ManageAttachments+ 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+ 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/KeyMap.hs view
@@ -0,0 +1,30 @@+module KeyMap+ ( keybindingModeMap+ )+where++import Prelude ()+import Prelude.MH++import Events.Keybindings+import Events.ChannelScroll+import Events.ChannelSelect+import Events.Main+import Events.MessageSelect+import Events.PostListOverlay+import Events.ShowHelp+import Events.UrlSelect+import Events.ManageAttachments++keybindingModeMap :: [(String, KeyConfig -> [Keybinding])]+keybindingModeMap =+ [ ("main", mainKeybindings)+ , ("help screen", helpKeybindings)+ , ("channel select", channelSelectKeybindings)+ , ("url select", urlSelectKeybindings)+ , ("channel scroll", channelScrollKeybindings)+ , ("message select", messageSelectKeybindings)+ , ("post list overlay", postListOverlayKeybindings)+ , ("attachment list", attachmentListKeybindings)+ , ("attachment file browse", attachmentBrowseKeybindings)+ ]
src/Main.hs view
@@ -8,20 +8,25 @@ import Config import Options import App-import Events ( ensureKeybindingConsistency )+import Events.Keybindings ( ensureKeybindingConsistency )+import KeyMap ( keybindingModeMap ) main :: IO () main = do opts <- grabOptions- configResult <- findConfig (optConfLocation opts)++ configResult <- if optIgnoreConfig opts+ then return $ Right defaultConfig+ else findConfig (optConfLocation opts)+ config <- case configResult of Left err -> do putStrLn $ "Error loading config: " <> err exitFailure Right c -> return c - case ensureKeybindingConsistency (configUserKeys config) of+ case ensureKeybindingConsistency (configUserKeys config) keybindingModeMap of Right () -> return () Left err -> do putStrLn $ "Configuration error: " <> err
src/Markdown.hs view
@@ -47,7 +47,8 @@ import Network.Mattermost.Types ( ServerTime(..) ) import Themes-import Types ( HighlightSet(..), userSigil, normalChannelSigil )+import Types ( HighlightSet(..), userSigil, normalChannelSigil+ , isNameFragment, takeWhileNameFragment ) import Types.Posts import Types.Messages @@ -258,11 +259,6 @@ hBox :: F.Foldable f => f (Widget a) -> Widget a hBox = B.hBox . toList ------- class ToWidget t where--- toWidget :: HighlightSet -> t -> Widget a- header :: Int -> Widget a header n = B.txt (T.replicate n "#") @@ -321,7 +317,7 @@ toInlineChunk is hSet = B.Widget B.Fixed B.Fixed $ do ctx <- B.getContext let width = ctx^.B.availWidthL- fs = toFragments is+ fs = toFragments hSet is ws = fmap gatherWidgets (split width hSet fs) B.render (vBox (fmap hBox ws)) @@ -371,14 +367,32 @@ | EditedRecently deriving (Eq, Show) --- We convert it pretty mechanically:-toFragments :: Inlines -> Seq Fragment-toFragments = go Normal+unsafeGetStr :: C.Inline -> Text+unsafeGetStr (C.Str t) = t+unsafeGetStr _ = error "BUG: unsafeGetStr called on non-Str Inline"++toFragments :: HighlightSet -> Inlines -> Seq Fragment+toFragments hSet = go Normal where go n c = case viewl c of C.Str t :< xs | t == editMarkingSentinel -> Fragment TEditSentinel Edited <| go n xs C.Str t :< xs | t == editRecentlyMarkingSentinel -> Fragment TEditRecentlySentinel EditedRecently <| go n xs+ C.Str t :< xs | userSigil `T.isPrefixOf` t ->+ let (uFrags, rest) = takeWhileNameFragment $ F.toList xs+ t' = T.concat $ t : (unsafeGetStr <$> F.toList uFrags)+ u = T.drop 1 t'+ sty = if u `Set.member` (hUserSet hSet)+ then User u+ else n+ in Fragment (TStr t') sty <| go n (S.fromList rest)+ C.Str t :< xs | normalChannelSigil `T.isPrefixOf` t ->+ let (cFrags, rest) = S.spanl isNameFragment xs+ cn = T.concat $ t : (unsafeGetStr <$> F.toList cFrags)+ sty = if cn `Set.member` (hChannelSet hSet)+ then Channel+ else n+ in Fragment (TStr cn) sty <| go n rest C.Str t :< xs -> Fragment (TStr t) n <| go n xs C.Space :< xs ->@@ -390,7 +404,7 @@ C.Link label url _ :< xs -> case toList label of [C.Str s] | s == url -> Fragment (TLink url) (Link url) <| go n xs- _ -> Fragment (TComplex $ toFragments label) (Link url) <| go n xs+ _ -> Fragment (TComplex $ toFragments hSet label) (Link url) <| go n xs C.RawHtml t :< xs -> Fragment (TRawHtml t) n <| go n xs C.Code t :< xs ->@@ -413,8 +427,6 @@ C.Entity t :< xs -> Fragment (TStr t) (Link t) <| go n xs EmptyL -> S.empty---- data SplitState = SplitState { splitChunks :: Seq (Seq Fragment)
src/Options.hs view
@@ -24,6 +24,7 @@ { optConfLocation :: Maybe FilePath , optLogLocation :: Maybe FilePath , optBehaviour :: Behaviour+ , optIgnoreConfig :: Bool } deriving (Eq, Show) defaultOptions :: Options@@ -31,6 +32,7 @@ { optConfLocation = Nothing , optLogLocation = Nothing , optBehaviour = Normal+ , optIgnoreConfig = False } optDescrs :: [OptDescr (Options -> Options)]@@ -47,6 +49,9 @@ , 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" ] mhVersion :: String
src/Scripts.hs view
@@ -36,17 +36,19 @@ ScriptNotFound -> do mhError $ NoSuchScript scriptName -runScript :: STM.TChan ProgramOutput -> FilePath -> Text -> IO (MH ())+runScript :: STM.TChan ProgramOutput -> FilePath -> Text -> IO (Maybe (MH ())) runScript 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- when (null $ programStderr po) $ do- mode <- use (csEditState.cedEditMode)- sendMessage mode (T.pack $ programStdout po)- ExitFailure _ -> return ()+ case null $ programStderr po of+ True -> Just $ do+ mode <- use (csEditState.cedEditMode)+ sendMessage mode (T.pack $ programStdout po) []+ False -> Nothing+ ExitFailure _ -> Nothing listScripts :: MH () listScripts = do
src/State/Async.hs view
@@ -26,13 +26,13 @@ -- message if it fails with a 'MattermostServerError'. tryMM :: IO a -- ^ The action to try (usually a MM API call)- -> (a -> IO (MH ()))+ -> (a -> IO (Maybe (MH ()))) -- ^ What to do on success- -> IO (MH ())+ -> IO (Maybe (MH ())) tryMM act onSuccess = do result <- liftIO $ try act case result of- Left e -> return $ mhError $ ServerError e+ Left e -> return $ Just $ mhError $ ServerError e Right value -> liftIO $ onSuccess value -- * Background Computation@@ -92,11 +92,11 @@ -- | Run a computation in the background, ignoring any results from it. doAsync :: AsyncPriority -> IO () -> MH ()-doAsync prio act = doAsyncWith prio (act >> return (return ()))+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 (MH ()) -> MH ()+doAsyncWith :: AsyncPriority -> IO (Maybe (MH ())) -> MH () doAsyncWith prio act = do let putChan = case prio of Preempt -> STM.unGetTChan@@ -106,11 +106,11 @@ doAsyncIO :: AsyncPriority -> ChatState -> IO () -> IO () doAsyncIO prio st act =- doAsyncWithIO prio st (act >> return (return ()))+ 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 (MH ()) -> IO ()+doAsyncWithIO :: AsyncPriority -> ChatState -> IO (Maybe (MH ())) -> IO () doAsyncWithIO prio st act = do let putChan = case prio of Preempt -> STM.unGetTChan@@ -125,7 +125,7 @@ -- ^ the priority for this async operation -> (Session -> TeamId -> IO a) -- ^ the async MM channel-based IO operation- -> (a -> MH ())+ -> (a -> Maybe (MH ())) -- ^ function to process the results in brick event handling -- context -> MH ()@@ -145,7 +145,7 @@ -- ^ The channel -> (Session -> TeamId -> ChannelId -> IO a) -- ^ the asynchronous Mattermost channel-based IO operation- -> (ChannelId -> a -> MH ())+ -> (ChannelId -> a -> Maybe (MH ())) -- ^ function to process the results in brick event handling context -> MH () @@ -158,5 +158,5 @@ -- | Use this convenience function if no operation needs to be -- performed in the MH state after an async operation completes.-endAsyncNOP :: ChannelId -> a -> MH ()-endAsyncNOP _ _ = return ()+endAsyncNOP :: ChannelId -> a -> Maybe (MH ())+endAsyncNOP _ _ = Nothing
+ src/State/Attachments.hs view
@@ -0,0 +1,35 @@+module State.Attachments+ ( showAttachmentList+ , resetAttachmentList+ , showAttachmentFileBrowser+ )+where++import Prelude ()+import Prelude.MH++import Brick ( vScrollToBeginning, viewportScroll )+import qualified Brick.Widgets.List as L+import qualified Brick.Widgets.FileBrowser as FB+import Lens.Micro.Platform ( (.=) )++import Types+++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+ browser <- liftIO $ FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser Nothing+ csEditState.cedFileBrowser .= browser+ setMode ManageAttachmentsBrowseFiles
+ src/State/Autocomplete.hs view
@@ -0,0 +1,197 @@+module State.Autocomplete+ ( 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 Command ( commandList, printArgSpec )+import State.Common+import Types hiding ( newState )+++-- | 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 :: MH ()+checkForAutocompletion = do+ result <- getCompleterForInput+ case result of+ Nothing -> resetAutocomplete+ Just (runUpdater, searchString) -> do+ prevResult <- use (csEditState.cedAutocomplete)+ let shouldUpdate = maybe True ((/= searchString) . _acPreviousSearchString)+ prevResult+ when shouldUpdate $ do+ csEditState.cedAutocompletePending .= Just searchString+ runUpdater searchString++getCompleterForInput :: MH (Maybe (Text -> MH (), Text))+getCompleterForInput = 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 (doUserAutoCompletion, T.tail w)+ | normalChannelSigil `T.isPrefixOf` w ->+ Just (doChannelAutoCompletion, T.tail w)+ | "```" `T.isPrefixOf` w ->+ Just (doSyntaxAutoCompletion, T.drop 3 w)+ | "/" `T.isPrefixOf` w && startCol == 0 ->+ Just (doCommandAutoCompletion, T.tail w)+ _ -> Nothing++doSyntaxAutoCompletion :: Text -> MH ()+doSyntaxAutoCompletion 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 searchString alts "Languages"++doCommandAutoCompletion :: Text -> MH ()+doCommandAutoCompletion 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 searchString alts "Commands"++-- | Attempt to re-use a cached autocomplete alternative list for+-- a given search string. If the cache contains no such entry (keyed+-- on search string), run the specified action, which is assumed to be+-- responsible for fetching the completion results from the server.+withCachedAutocompleteResults :: Text+ -- ^ The autocomplete UI label for the+ -- results to be used+ -> Text+ -- ^ The search string to look for in the+ -- cache+ -> MH ()+ -- ^ The action to execute on a cache miss+ -> MH ()+withCachedAutocompleteResults label searchString act = do+ mCache <- preuse (csEditState.cedAutocomplete._Just.acCachedResponses)++ -- Does the cache have results for this search string? If so, use+ -- them; otherwise invoke the specified action.+ case HM.lookup searchString =<< mCache of+ Just alts -> setCompletionAlternatives searchString alts label+ Nothing -> act++doUserAutoCompletion :: Text -> MH ()+doUserAutoCompletion searchString = do+ session <- getSession+ myTid <- gets myTeamId+ myUid <- gets myUserId+ cId <- use csCurrentChannelId+ let label = "Users"++ withCachedAutocompleteResults label 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)++ return $ Just $ setCompletionAlternatives searchString alts label++doChannelAutoCompletion :: Text -> MH ()+doChannelAutoCompletion searchString = do+ session <- getSession+ tId <- gets myTeamId+ let label = "Channels"+ cs <- use csChannels++ withCachedAutocompleteResults label 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 searchString alts label++setCompletionAlternatives :: Text -> [AutocompleteAlternative] -> Text -> MH ()+setCompletionAlternatives searchString alts ty = do+ let list = L.list CompletionList (V.fromList $ F.toList alts) 1+ state = AutocompleteState { _acPreviousSearchString = searchString+ , _acCompletionList =+ list & L.listSelectedL .~ Nothing+ , _acListElementType = ty+ , _acCachedResponses = HM.fromList [(searchString, alts)]+ }++ 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+ _ ->+ -- 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/ChannelSelect.hs view
@@ -10,90 +10,84 @@ import Prelude () import Prelude.MH +import Brick.Widgets.Edit ( getEditContents ) import Data.Char ( isUpper )-import Data.List ( findIndex ) import qualified Data.Text as T import Lens.Micro.Platform -import Types+import qualified Network.Mattermost.Types as MM +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 succ+channelSelectNext = updateSelectedMatch Z.right -- Select the previous match in channel selection mode. channelSelectPrevious :: MH ()-channelSelectPrevious = updateSelectedMatch pred+channelSelectPrevious = updateSelectedMatch Z.left updateChannelSelectMatches :: MH () updateChannelSelectMatches = do- -- Given the current channel select string, find all the channel and- -- user matches and then update the match lists.+ st <- use id+ input <- use (csChannelSelectState.channelSelectInput)- let pat = parseChannelSelectPattern input- chanNameMatches = case pat of+ cconfig <- use csClientConfig+ prefs <- use (csResources.crUserPreferences)++ let pat = parseChannelSelectPattern $ T.concat $ getEditContents input+ chanNameMatches e = case pat of Nothing -> const Nothing- Just p -> if T.null input- then const Nothing- else applySelectPattern p+ Just p -> applySelectPattern p e patTy = case pat of Nothing -> Nothing+ Just CSPAny -> Nothing Just (CSP ty _) -> Just ty - chanNames <- gets (sort . allChannelNames)- uList <- use (to sortedUserList)- displayNick <- use (to useNickname)- let chanMatches = if patTy == Just UsersOnly- then mempty- else catMaybes (fmap chanNameMatches chanNames)- displayName uInf- | displayNick = uInf^.uiNickName.non (uInf^.uiName)- | otherwise = uInf^.uiName- usernameMatches = if patTy == Just ChannelsOnly- then mempty- else catMaybes (fmap (chanNameMatches . displayName) uList)+ let chanMatches e chan =+ if patTy == Just PrefixDMOnly+ then Nothing+ else if chan^.ccInfo.cdType /= MM.Group+ then chanNameMatches e $ chan^.ccInfo.cdName+ else Nothing+ groupChanMatches e chan =+ if patTy == Just PrefixNonDMOnly+ then Nothing+ else if chan^.ccInfo.cdType == MM.Group+ then chanNameMatches e $ chan^.ccInfo.cdName+ 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 - newInput <- use (csChannelSelectState.channelSelectInput)- csChannelSelectState.channelMatches .= chanMatches- csChannelSelectState.userMatches .= usernameMatches- csChannelSelectState.selectedMatch %= \oldMatch ->- -- If the user input exactly matches one of the matches, prefer- -- that one. Otherwise, if the previously selected match is- -- still a possible match, leave it selected. Otherwise revert- -- to the first available match.- let unames = matchFull <$> usernameMatches- cnames = matchFull <$> chanMatches- firstAvailableMatch =- if null chanMatches- then if null unames- then Nothing- else Just $ UserMatch $ head unames- else Just $ ChannelMatch $ head cnames- newMatch = case oldMatch of- Just (UserMatch u) ->- if newInput `elem` unames- then Just $ UserMatch newInput- else if u `elem` unames- then oldMatch- else firstAvailableMatch- Just (ChannelMatch c) ->- if newInput `elem` cnames- then Just $ ChannelMatch $ newInput- else if c `elem` cnames- then oldMatch- else firstAvailableMatch- Nothing -> firstAvailableMatch- in newMatch+ preserveFocus Nothing _ = False+ preserveFocus (Just m) m2 = matchEntry m == matchEntry m2 -applySelectPattern :: ChannelSelectPattern -> Text -> Maybe ChannelSelectMatch-applySelectPattern (CSP ty pat) chanName = do- let applyType Infix | pat `T.isInfixOf` normalizedChanName =+ 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@@ -105,11 +99,11 @@ let (b, a) = T.splitAt (T.length pat) chanName return ("", b, a) - applyType UsersOnly | pat `T.isPrefixOf` normalizedChanName = do+ applyType PrefixDMOnly | pat `T.isPrefixOf` normalizedChanName = do let (b, a) = T.splitAt (T.length pat) chanName return ("", b, a) - applyType ChannelsOnly | pat `T.isPrefixOf` normalizedChanName = do+ applyType PrefixNonDMOnly | pat `T.isPrefixOf` normalizedChanName = do let (b, a) = T.splitAt (T.length pat) chanName return ("", b, a) @@ -128,12 +122,13 @@ else T.toLower chanName (pre, m, post) <- applyType ty- return $ ChannelSelectMatch pre m post chanName+ 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 UsersOnly $ T.tail pat- | normalChannelSigil `T.isPrefixOf` pat -> Just $ CSP ChannelsOnly $ T.tail pat+ 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@@ -152,34 +147,8 @@ tys -> error $ "BUG: invalid channel select case: " <> show tys -- Update the channel selection mode match cursor. The argument function--- determines how the new cursor position is computed from the old--- one. The new cursor position is automatically wrapped around to the--- beginning or end of the channel selection match list, so cursor--- transformations do not have to do index validation. If the current--- match (e.g. the sentinel "") is not found in the match list, this--- sets the cursor position to the first match, if any.-updateSelectedMatch :: (Int -> Int) -> MH ()-updateSelectedMatch nextIndex = do- chanMatches <- use (csChannelSelectState.channelMatches)- usernameMatches <- use (csChannelSelectState.userMatches)-- csChannelSelectState.selectedMatch %= \oldMatch ->- -- Make the list of all matches, in display order.- let allMatches = concat [ (ChannelMatch . matchFull) <$> chanMatches- , (UserMatch . matchFull) <$> usernameMatches- ]- defaultMatch = if null allMatches- then Nothing- else Just $ allMatches !! 0- in case oldMatch of- Nothing -> defaultMatch- Just oldMatch' -> case findIndex (== oldMatch') allMatches of- Nothing -> defaultMatch- Just i ->- let newIndex = if tmpIndex < 0- then length allMatches - 1- else if tmpIndex >= length allMatches- then 0- else tmpIndex- tmpIndex = nextIndex i- in Just $ allMatches !! newIndex+-- 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 view
@@ -1,12 +1,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} module State.Channels- ( updateViewed+ ( updateSidebar+ , updateViewed , updateViewedChan , refreshChannel , refreshChannelsAndUsers , setFocus- , setFocusWith , refreshChannelById , applyPreferenceChange , leaveChannel@@ -16,9 +16,13 @@ , getNextUnreadUserOrChannel , nextUnreadChannel , nextUnreadUserOrChannel+ , createOrFocusDMChannel+ , clearChannelUnreadStatus , prevChannel , nextChannel , recentChannel+ , hideDMChannel+ , hideCurrentDMChannel , createGroupChannel , showGroupChannelPref , channelHistoryForward@@ -26,6 +30,7 @@ , handleNewChannel , createOrdinaryChannel , handleChannelInvite+ , addUserByNameToCurrentChannel , addUserToCurrentChannel , removeUserFromCurrentChannel , removeChannelFromState@@ -36,29 +41,35 @@ , joinChannel , joinChannelByName , startJoinChannel- , changeChannel+ , changeChannelByName , setChannelTopic , beginCurrentChannelDeleteConfirm , toggleChannelListVisibility+ , showChannelInSidebar ) where import Prelude () import Prelude.MH -import Brick.Main ( viewportScroll, vScrollToBeginning, invalidateCache )+import Brick.Main ( viewportScroll, vScrollToBeginning, invalidateCache, invalidateCacheEntry ) import Brick.Widgets.Edit ( applyEdit, getEditContents, editContentsL ) import Brick.Widgets.List ( list ) import Control.Concurrent.Async ( runConcurrently, Concurrently(..) )+import qualified Control.Concurrent.STM as STM import Control.Exception ( SomeException, try ) import Data.Char ( isAlphaNum ) import qualified Data.HashMap.Strict as HM+import qualified Data.Foldable as F import Data.Function ( on )+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 qualified Data.Vector as V import Data.Text.Zipper ( textZipper, clearZipper, insertMany, gotoEOL )+import Data.Time.Clock ( getCurrentTime ) import Lens.Micro.Platform import qualified Network.Mattermost.Endpoints as MM@@ -67,36 +78,75 @@ import InputHistory import State.Common+import {-# SOURCE #-} State.Messages ( fetchVisibleIfNeeded ) import State.Users import State.Flagging-import State.Setup.Threads ( updateUserStatuses ) import Types import Types.Common import Zipper ( Zipper ) import qualified Zipper as Z -updateViewed :: MH ()-updateViewed = do+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+ csFocus %= Z.updateList (mkChannelZipperList now cconfig prefs cs us)++ -- Send the new zipper to the status update thread so that we can+ -- fetch the statuses for the users in the new sidebar.+ newZ <- use csFocus+ statusChan <- use (csResources.crStatusUpdateChan)+ liftIO $ STM.atomically $ STM.writeTChan statusChan newZ++ -- 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 =<< use csCurrentChannelId+ 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.-updateViewedChan :: ChannelId -> MH ()-updateViewedChan cId = use csConnectionStatus >>= \case+--+-- 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 <- use csRecentChannel+ pId <- if updatePrev+ then use csRecentChannel+ else return Nothing doAsyncChannelMM Preempt cId (\s _ c -> MM.mmViewChannel UserMe c pId s)- (\c () -> setLastViewedFor pId c)+ (\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+ -- 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@@ -108,6 +158,31 @@ mh invalidateCache csShowChannelList %= not +hideCurrentDMChannel :: MH ()+hideCurrentDMChannel = hideDMChannel =<< use csCurrentChannelId++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.@@ -150,93 +225,80 @@ doAsyncChannelMM Preempt cId (\ s _ _ -> (,) <$> MM.mmGetChannel cId s <*> MM.mmGetChannelMember cId UserMe s)- (\pcid (cwd, member) -> csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd member)+ (\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 -> csChannels %= (channelByIdL p %~ (clearNewMessageIndicator . clearEditedThreshold))+ 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- -- The below code is a duplicate of mmGetAllChannelsWithDataForUser- -- function, which has been inlined here to gain a concurrency- -- benefit. 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) - let dataMap = HM.fromList $ toList $ (\d -> (channelMemberChannelId d, d)) <$> datas+ -- 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 - asyncFetchAllUsers page accum final = do- doAsyncWith Preempt $ do- let pageSize = 200- userQuery = MM.defaultUserQuery- { MM.userQueryPage = Just page- , MM.userQueryPerPage = Just pageSize- , MM.userQueryInTeam = Just myTId- }- batch <- MM.mmGetUsers userQuery session-- return $ case length batch < pageSize of- True -> do- let users = accum <> batch- forM_ users $ \u -> do- when (not $ userDeleted u) $ do- result <- gets (userById (getId u))- when (isNothing result) $ handleNewUserDirect u- setUserIdSet (userId <$> users)- final- False ->- asyncFetchAllUsers (page + 1) (accum <> batch) final-- return $ do- asyncFetchAllUsers 0 mempty $ do- forM_ chansWithData $ uncurry refreshChannel- lock <- use (csResources.crUserStatusLock)- setVar <- use (csResources.crUserIdSet)- doAsyncWith Preempt $ updateUserStatuses setVar lock session+ 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.-refreshChannel :: Channel -> ChannelMember -> MH ()-refreshChannel chan member = do+--+-- 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 - -- If this is a group channel that the user has chosen to hide or if- -- the channel is not a channel for the current session's team, ignore- -- the refresh request.- isHidden <- channelHiddenPreference cId- case isHidden || not ourTeam of+ 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 chan member+ handleNewChannel False upd chan member updateChannelInfo cId chan member -channelHiddenPreference :: ChannelId -> MH Bool-channelHiddenPreference cId = do- prefs <- use (csResources.crUserPreferences.userPrefGroupChannelPrefs)- let matching = filter (\p -> fst p == cId) (HM.toList prefs)- return $ any (not . snd) matching--handleNewChannel :: Bool -> Channel -> ChannelMember -> MH ()+handleNewChannel :: Bool -> SidebarUpdate -> Channel -> ChannelMember -> MH () handleNewChannel = handleNewChannel_ True handleNewChannel_ :: Bool@@ -247,19 +309,26 @@ -> 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 nc member = do+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 nc+ makeClientChannel (me^.userIdL) nc st <- use id @@ -271,23 +340,11 @@ -- 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).- mName <- case chType of+ register <- case chType of Direct -> case userIdForDMChannel (myUserId st) (sanitizeUserText $ channelName nc) of- -- If this is a direct channel but we can't extract- -- a user ID from the name, then it failed to- -- parse. We need to assign a channel name in our- -- channel map, and the best we can do to preserve- -- uniqueness is to use the channel name string.- -- This is undesirable but direct channels never get- -- rendered directly; they only get used by first- -- looking up usernames. So this name should never- -- appear anywhere, but at least we can go ahead and- -- register the channel and handle events for it.- -- That isn't very useful but it's probably better- -- than ignoring this entirely.- Nothing -> return $ Just $ sanitizeUserText $ channelName nc+ Nothing -> return True Just otherUserId ->- case usernameForUserId otherUserId st of+ 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@@ -306,60 +363,106 @@ -- problems as above). Nothing -> do case permitPostpone of- False -> return $ Just $ sanitizeUserText $ channelName nc+ False -> return True True -> do- handleNewUsers $ Seq.singleton otherUserId+ mhLog LogAPI $ T.pack $ "handleNewChannel_: about to call handleNewUsers for " <> show otherUserId+ handleNewUsers (Seq.singleton otherUserId) (return ()) doAsyncWith Normal $- return $ handleNewChannel_ False switch nc member- return Nothing- Just ncUsername ->- return $ Just $ ncUsername- _ -> return $ Just $ preferredChannelName nc+ return $ Just $ handleNewChannel_ False switch sbUpdate nc member+ return False+ Just _ -> return True+ _ -> return True - case mName of- Nothing -> return ()- Just name -> do- addChannelName chType (getId nc) name- csChannels %= addChannel (getId nc) cChannel- refreshChannelZipper+ 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.- lastReq <- use csLastJoinRequest- wasLast <- case lastReq of- Just cId | cId == getId nc -> do- csLastJoinRequest .= Nothing- return True- _ -> return False+ pending1 <- checkPendingChannelChange (ChangeByChannelId $ getId nc)+ pending2 <- case cChannel^.ccInfo.cdDMUserId of+ Nothing -> return False+ Just uId -> checkPendingChannelChange (ChangeByUserId uId) - when (switch || wasLast) $ setFocus (getId nc)+ when (switch || pending1 || pending2) $ setFocus (getId nc) +-- | Check to see whether the specified channel has been queued up to+-- be switched to now that the channel is registered in the state. If+-- so, return True and clear the state. Otherwise return False.+checkPendingChannelChange :: PendingChannelChange -> MH Bool+checkPendingChannelChange change = do+ pending <- use csPendingChannelChange+ case pending of+ Just p | p == change -> do+ csPendingChannelChange .= Nothing+ return True+ _ -> return 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- mOldChannel <- preuse $ csChannel(cid)- case mOldChannel of- Nothing -> return ()- Just old ->- let oldName = old^.ccInfo.cdName- newName = preferredChannelName new- in if oldName == newName- then return ()- else do- removeChannelName oldName- addChannelName (channelType new) cid newName-+ mh $ invalidateCacheEntry $ ChannelMessages cid csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member+ updateSidebar setFocus :: ChannelId -> MH ()-setFocus cId = setFocusWith (Z.findRight (== cId))+setFocus cId = do+ showChannelInSidebar cId True+ setFocusWith True (Z.findRight ((== cId) . channelListEntryChannelId)) -setFocusWith :: (Zipper ChannelId -> Zipper ChannelId) -> MH ()-setFocusWith f = do+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 -> return ()+ Just ch -> do+ 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 ()+setFocusWith updatePrev f = do oldZipper <- use csFocus let newZipper = f oldZipper newFocus = Z.focus newZipper@@ -368,9 +471,16 @@ -- If we aren't changing anything, skip all the book-keeping because -- we'll end up clobbering things like csRecentChannel. when (newFocus /= oldFocus) $ do+ mh $ invalidateCacheEntry ChannelSidebar+ resetAutocomplete preChangeChannelCommon csFocus .= newZipper- updateViewed++ now <- liftIO getCurrentTime+ newCid <- use csCurrentChannelId+ csChannel(newCid).ccInfo.cdSidebarShowOverride .= Just now++ updateViewed updatePrev postChangeChannelCommon postChangeChannelCommon :: MH ()@@ -380,6 +490,7 @@ updateChannelListScroll loadLastEdit resetCurrentEdit+ fetchVisibleIfNeeded resetCurrentEdit :: MH () resetCurrentEdit = do@@ -443,27 +554,60 @@ , 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- mChan <- preuse $ csChannel cId+ case groupChannelShow g of+ True -> do+ pending <- checkPendingChannelChange $ ChangeByChannelId cId+ when pending $ setFocus cId+ False -> do+ csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing - case (mChan, groupChannelShow g) of- (Just _, False) ->- -- If it has been set to hidden and we are showing it,- -- remove it from the state.- removeChannelFromState cId- (Nothing, True) ->- -- If it has been set to showing and we are not showing- -- it, ask for a load/refresh.- refreshChannelById cId- _ -> return () | otherwise -> return () refreshChannelById :: ChannelId -> MH ()@@ -472,36 +616,35 @@ doAsyncWith Preempt $ do cwd <- MM.mmGetChannel cId session member <- MM.mmGetChannelMember cId UserMe session- return $ refreshChannel cwd member+ return $ Just $ do+ refreshChannel SidebarUpdateImmediate cwd member removeChannelFromState :: ChannelId -> MH () removeChannelFromState cId = do withChannel cId $ \ chan -> do- let cName = chan^.ccInfo.cdName- chType = chan^.ccInfo.cdType- when (chType /= Direct) $ do+ when (chan^.ccInfo.cdType /= Direct) $ do origFocus <- use csCurrentChannelId- when (origFocus == cId) nextChannel+ when (origFocus == cId) nextChannelSkipPrevView csEditState.cedInputHistoryPosition .at cId .= Nothing csEditState.cedLastChannelInput .at cId .= Nothing -- Update input history csEditState.cedInputHistory %= removeChannelHistory cId- -- Remove channel name mappings- removeChannelName cName -- Update msgMap- csChannels %= filteredChannels ((/=) cId . fst)+ csChannels %= removeChannel cId -- Remove from focus zipper- csFocus %= Z.filterZipper (/= cId)+ csFocus %= Z.filterZipper ((/= cId) . channelListEntryChannelId)+ updateSidebar nextChannel :: MH ()-nextChannel = do- st <- use id- setFocusWith (getNextNonDMChannel st Z.right)+nextChannel = setFocusWith True Z.right +-- | 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+ prevChannel :: MH ()-prevChannel = do- st <- use id- setFocusWith (getNextNonDMChannel st Z.left)+prevChannel = setFocusWith True Z.left recentChannel :: MH () recentChannel = do@@ -513,12 +656,12 @@ nextUnreadChannel :: MH () nextUnreadChannel = do st <- use id- setFocusWith (getNextUnreadChannel st)+ setFocusWith True (getNextUnreadChannel st) nextUnreadUserOrChannel :: MH () nextUnreadUserOrChannel = do st <- use id- setFocusWith (getNextUnreadUserOrChannel st)+ setFocusWith True (getNextUnreadUserOrChannel st) leaveChannel :: ChannelId -> MH () leaveChannel cId = leaveChannelIfPossible cId False@@ -550,7 +693,7 @@ , MM.userQueryInChannel = Just cId } in toList <$> MM.mmGetUsers query s)- (\_ members -> do+ (\_ members -> Just $ do -- If the channel is private: -- * leave it if we aren't the last member. -- * delete it if we are.@@ -574,81 +717,63 @@ ) getNextUnreadChannel :: ChatState- -> (Zipper ChannelId -> Zipper ChannelId)+ -> (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 (\cId -> hasUnread st cId && (cId /= st^.csCurrentChannelId))+ Z.findRight (\e ->+ let cId = channelListEntryChannelId e+ in hasUnread st cId && (cId /= st^.csCurrentChannelId)) getNextUnreadUserOrChannel :: ChatState- -> Zipper ChannelId- -> Zipper ChannelId+ -> Zipper a ChannelListEntry+ -> Zipper a ChannelListEntry getNextUnreadUserOrChannel st z = -- Find the next unread channel, prefering direct messages- let isDM c = getChannelType st c == Direct- isFresh c = hasUnread st c && (c /= st^.csCurrentChannelId)- in fromMaybe (Z.findRight isFresh z) (Z.maybeFindRight (\cId -> isDM cId && isFresh cId) z)---- | Select the next channel in the channel zipper that is not a DM--- channel.------ If the currently selected channel is a DM channel, do nothing because--- we want to prevent zipper navigation away from direct channels--- because we don't support navigating *back* to such channels using the--- same navigation bindings.-getNextNonDMChannel :: ChatState- -> (Zipper ChannelId -> Zipper ChannelId)- -> (Zipper ChannelId -> Zipper ChannelId)-getNextNonDMChannel st shift z =- if getChannelType st (Z.focus z) == Direct- then z- else go (shift z)- where go z'- | fType z' /= Direct = z'- | otherwise = go (shift z')- fType onz = getChannelType st (Z.focus onz)--getChannelType :: ChatState -> ChannelId -> Type-getChannelType st cId =- st^.(csChannels.to (findChannelById cId)) ^?! _Just.ccInfo.cdType+ 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- st <- use id me <- gets myUser-- let usernames = T.words usernameList- findUserIds [] = return []- findUserIds (n:ns) = do- case userByUsername n st of- Nothing -> do- mhError $ NoSuchUser n- return []- Just u -> (u^.uiId:) <$> findUserIds ns+ session <- getSession+ cs <- use csChannels - results <- findUserIds usernames+ 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.- when (length results == length usernames) $ do- session <- getSession- doAsyncWith Preempt $ do- chan <- MM.mmCreateGroupMessageChannel (Seq.fromList results) session- let pref = showGroupChannelPref (channelId chan) (me^.userIdL)- -- It's possible that the channel already existed, in which- -- case we want to request a preference change to show it.- MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session- cwd <- MM.mmGetChannel (channelId chan) session- member <- MM.mmGetChannelMember (channelId chan) UserMe session- return $ do- applyPreferenceChange pref- handleNewChannel True cwd member+ -- 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+ -- If we already know about the channel ID, that means+ -- the channel already exists so we can just switch to+ -- it.+ case findChannelById (channelId chan) cs of+ Just _ -> return $ Just $ setFocus (channelId chan)+ Nothing -> do+ let pref = showGroupChannelPref (channelId chan) (me^.userIdL)+ MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session+ return $ Just $ do+ applyPreferenceChange pref+ 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@@ -717,7 +842,7 @@ member <- MM.mmGetChannelMember (getId c) UserMe session return (chan, member) )- (return . uncurry (handleNewChannel True))+ (return . Just . uncurry (handleNewChannel True SidebarUpdateImmediate)) -- | When another user adds us to a channel, we need to fetch the -- channel info for that channel.@@ -727,36 +852,29 @@ doAsyncWith Normal $ do member <- MM.mmGetChannelMember cId UserMe session tryMM (MM.mmGetChannel cId session)- (\cwd -> return $ handleNewChannel False cwd member)+ (\cwd -> return $ Just $ handleNewChannel False SidebarUpdateImmediate cwd member) -addUserToCurrentChannel :: Text -> MH ()-addUserToCurrentChannel uname = do- -- First: is this a valid username?- result <- gets (userByUsername uname)- case result of- Just 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 (return ()))- _ -> do- mhError $ NoSuchUser uname+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 = do- -- First: is this a valid username?- result <- gets (userByUsername uname)- case result of- Just u -> do- cId <- use csCurrentChannelId- session <- getSession- doAsyncWith Normal $ do- tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session)- (const $ return (return ()))- _ -> do- mhError $ NoSuchUser uname+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@@ -783,7 +901,7 @@ tId <- gets myTeamId doAsyncWith Preempt $ do result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session- return $ case result of+ return $ Just $ case result of Left (_::SomeException) -> mhError $ NoSuchChannel rawName Right chan -> joinChannel $ getId chan @@ -805,7 +923,7 @@ else loop chans (start+1) chans <- Seq.filter (\ c -> not (channelId c `elem` myChannels)) <$> loop mempty 0 let sortedChans = V.fromList $ toList $ Seq.sortBy (compare `on` channelName) chans- return $ do+ return $ Just $ do csJoinChannelList .= (Just $ list JoinChannelList sortedChans 2) setMode JoinChannel@@ -822,70 +940,56 @@ Nothing -> do myId <- gets myUserId let member = MinChannelMember myId chanId- csLastJoinRequest .= Just chanId+ csPendingChannelChange .= (Just $ ChangeByChannelId chanId) doAsyncChannelMM Preempt chanId (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP -attemptCreateDMChannel :: Text -> MH ()-attemptCreateDMChannel name = do- mCid <- gets (channelIdByUsername name)- me <- gets myUser- displayNick <- use (to useNickname)- uList <- use (to sortedUserList)- let myName = if displayNick && not (T.null $ sanitizeUserText $ userNickname me)- then sanitizeUserText $ userNickname me- else me^.userUsernameL- when (name /= myName) $ do- let uName = if displayNick- then- maybe name (view uiName)- $ findUserByNickname uList name- else name- mUid <- gets (userIdForUsername uName)- if isJust mUid && isNothing mCid- then do+createOrFocusDMChannel :: UserInfo -> MH ()+createOrFocusDMChannel user = do+ cs <- use csChannels+ case getDmChannelFor (user^.uiId) cs of+ Just cId -> setFocus cId+ Nothing -> do -- We have a user of that name but no channel. Time to make one!- let Just uId = mUid myId <- gets myUserId session <- getSession+ csPendingChannelChange .= (Just $ ChangeByUserId $ user^.uiId) doAsyncWith Normal $ do -- create a new channel- nc <- MM.mmCreateDirectMessageChannel (uId, myId) session -- tId uId- cwd <- MM.mmGetChannel (getId nc) session- member <- MM.mmGetChannelMember (getId nc) UserMe session- return $ handleNewChannel True cwd member- else- mhError $ NoSuchUser name+ void $ MM.mmCreateDirectMessageChannel (user^.uiId, myId) session+ return Nothing -- | This switches to the named channel or creates it if it is a missing -- but valid user channel.-changeChannel :: Text -> MH ()-changeChannel name = do- result <- gets (channelIdByName name)- user <- gets (userByUsername name)- let err = mhError $ AmbiguousName name+changeChannelByName :: Text -> MH ()+changeChannelByName name = do+ mCId <- gets (channelIdByChannelName name)+ mDMCId <- gets (channelIdByUsername name) - case result of- (Nothing, Nothing)- -- We know about the user but there isn't already a DM- -- channel, so create one.- | Just _ <- user -> attemptCreateDMChannel name- -- There were no matches of any kind.- | otherwise -> 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 _ <- user -> err- -- We matched a channel only.- | otherwise -> setFocus cId- (Nothing, Just cId) ->- -- We matched a user only and there is already a DM channel.- setFocus cId- (Just _, Just _) ->- -- We matched both a channel and a user.- err+ 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+ -- 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@@ -893,7 +997,7 @@ let patch = defaultChannelPatch { channelPatchHeader = Just msg } doAsyncChannelMM Preempt cId (\s _ _ -> MM.mmPatchChannel cId patch s)- (\_ _ -> return ())+ (\_ _ -> Nothing) beginCurrentChannelDeleteConfirm :: MH () beginCurrentChannelDeleteConfirm = do
src/State/Common.hs view
@@ -5,7 +5,8 @@ , runLoggedCommand -- * Posts- , messagesFromPosts+ , installMessagesFromPosts+ , updatePostMap -- * Utilities , postInfoMessage@@ -13,6 +14,7 @@ , postErrorMessage' , addEmoteFormatting , removeEmoteFormatting+ , fetchUsersByUsername , module State.Async )@@ -21,6 +23,7 @@ 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@@ -51,36 +54,62 @@ -- * Client Messages -messagesFromPosts :: Posts -> MH Messages-messagesFromPosts p = do+-- | 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, Set.Set Text)+installMessagesFromPosts postCollection = do flags <- use (csResources.crFlaggedPosts)- csPostMap %= HM.union postMap- let msgs = postsToMessages (maybeFlag flags . clientPostToMessage) (clientPost <$> ps)- postsToMessages f = foldr (addMessage . f) noMessages- return msgs++ -- 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)+ postsToMessages = foldr addNext (noMessages, mempty)++ return $ postsToMessages clientPosts where- postMap :: HashMap PostId Message- postMap = HM.fromList- [ ( pId- , clientPostToMessage (toClientPost x Nothing)- )- | (pId, x) <- HM.toList (p^.postsPostsL)- ] maybeFlag flagSet msg | Just (MessagePostId pId) <- msg^.mMessageId, pId `Set.member` flagSet = msg & mFlagged .~ True | otherwise = msg- -- n.b. postsOrder is most recent first- ps = findPost <$> (Seq.reverse $ postsOrder p)- clientPost :: Post -> ClientPost- clientPost x = toClientPost x (postId <$> parent x) parent x = do parentId <- x^.postRootIdL- HM.lookup parentId (p^.postsPostsL)- findPost pId = case HM.lookup pId (postsPosts p) of+ 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@@ -89,6 +118,7 @@ let addCMsg = ccContents.cdMessages %~ (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) csChannels %= modifyChannelById cid addCMsg+ mh $ invalidateCacheEntry $ ChannelMessages cid let msgTy = case msg^.cmType of Error -> LogError@@ -117,8 +147,8 @@ (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) return $ st & csChannels %~ modifyChannelById cId addEMsg -openURL :: LinkChoice -> MH Bool-openURL link = do+openURL :: OpenInBrowser -> MH Bool+openURL thing = do cfg <- use (csResources.crConfiguration) case configURLOpenCommand cfg of Nothing ->@@ -127,9 +157,13 @@ session <- getSession -- Is the URL referring to an attachment?- let act = case link^.linkFileId of- Nothing -> prepareLink link- Just fId -> prepareAttachment fId session+ 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@@ -142,7 +176,7 @@ args <- act runLoggedCommand False outputChan (T.unpack urlOpenCommand) args Nothing Nothing- return $ return ()+ return Nothing True -> do -- If there isn't a new message cutoff showing in -- the current channel, set one. This way, while the@@ -168,7 +202,23 @@ mhSuspendAndResume $ \st -> do args <- act- void $ runInteractiveCommand (T.unpack urlOpenCommand) args+ 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@@ -257,3 +307,19 @@ addEmoteFormatting :: T.Text -> T.Text addEmoteFormatting t = "*" <> t <> "*"++-- | 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.+fetchUsersByUsername :: [Text] -> MH ()+fetchUsersByUsername [] = return ()+fetchUsersByUsername usernames = do+ st <- use id+ session <- getSession+ let missing = filter (\n -> (not $ T.null n) && (isNothing $ userByUsername n st)) usernames+ when (not $ null missing) $ do+ mhLog LogGeneral $ T.pack $ "fetchUsersByUsername: getting " <> show usernames+ doAsyncWith Normal $ do+ results <- mmGetUsersByUsernames (Seq.fromList missing) session+ return $ Just $ do+ forM_ results (\u -> addNewUser $ userInfoFromUser u True)
src/State/Editing.hs view
@@ -3,17 +3,19 @@ module State.Editing ( requestSpellCheck , editingKeybindings- , toggleMessagePreview , toggleMultilineEditing , invokeExternalEditor , handlePaste , handleEditingInput+ , cancelAutocompleteOrReplyOrEdit+ , replyToLatestMessage ) where import Prelude () import Prelude.MH +import Brick.Main ( invalidateCache ) import Brick.Widgets.Edit ( Editor, applyEdit , handleEditorEvent , getEditContents, editContentsL ) import qualified Codec.Binary.UTF8.Generic as UTF8@@ -35,20 +37,26 @@ import qualified System.Process as Sys import Text.Aspell ( AspellResponse(..), mistakeWord, askAspell ) -import Network.Mattermost.Types (Post(..))+import Network.Mattermost.Types ( Post(..) ) import Config import Events.Keybindings import State.Common-import Types+import State.Autocomplete+import State.Attachments+import Types hiding ( newState ) import Types.Common ( sanitizeChar, sanitizeUserText' ) startMultilineEditing :: MH ()-startMultilineEditing = csEditState.cedMultiline .= True+startMultilineEditing = do+ mh invalidateCache+ csEditState.cedMultiline .= True toggleMultilineEditing :: MH ()-toggleMultilineEditing = csEditState.cedMultiline %= not+toggleMultilineEditing = do+ mh invalidateCache+ csEditState.cedMultiline %= not invokeExternalEditor :: MH () invokeExternalEditor = do@@ -83,9 +91,6 @@ return $ st & csEditState.cedEditor.editContentsL .~ (Z.textZipper tmpLines Nothing) Sys.ExitFailure _ -> return st -toggleMessagePreview :: MH ()-toggleMessagePreview = csShowMessagePreview %= not- handlePaste :: BS.ByteString -> MH () handlePaste bytes = do let pasteStr = T.pack (UTF8.toString bytes)@@ -107,7 +112,6 @@ [ kb "Transpose the final two characters" (EvKey (KChar 't') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.transposeChars- csEditState.cedCompleter .= Nothing , kb "Go to the start of the current line" (EvKey (KChar 'a') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.gotoBOL@@ -117,39 +121,30 @@ , kb "Delete the character at the cursor" (EvKey (KChar 'd') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.deleteChar- csEditState.cedCompleter .= Nothing , kb "Delete from the cursor to the start of the current line" (EvKey (KChar 'u') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.killToBOL- csEditState.cedCompleter .= Nothing , kb "Move one character to the right" (EvKey (KChar 'f') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.moveRight- csEditState.cedCompleter .= Nothing , kb "Move one character to the left" (EvKey (KChar 'b') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.moveLeft- csEditState.cedCompleter .= Nothing , kb "Move one word to the right" (EvKey (KChar 'f') [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.moveWordRight- csEditState.cedCompleter .= Nothing , kb "Move one word to the left" (EvKey (KChar 'b') [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.moveWordLeft- csEditState.cedCompleter .= Nothing , kb "Delete the word to the left of the cursor" (EvKey KBS [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.deletePrevWord- csEditState.cedCompleter .= Nothing , kb "Delete the word to the left of the cursor" (EvKey (KChar 'w') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.deletePrevWord- csEditState.cedCompleter .= Nothing , kb "Delete the word to the right of the cursor" (EvKey (KChar 'd') [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.deleteWord- csEditState.cedCompleter .= Nothing , kb "Move the cursor to the beginning of the input" (EvKey KHome []) $ do csEditState.cedEditor %= applyEdit gotoHome@@ -162,12 +157,10 @@ let restOfLine = Z.currentLine (Z.killToBOL z) csEditState.cedYankBuffer .= restOfLine csEditState.cedEditor %= applyEdit Z.killToEOL- csEditState.cedCompleter .= Nothing , kb "Paste the current buffer contents at the cursor" (EvKey (KChar 'y') [MCtrl]) $ do buf <- use (csEditState.cedYankBuffer) csEditState.cedEditor %= applyEdit (Z.insertMany buf)- csEditState.cedCompleter .= Nothing ] where withUserTypingAction (KB {..}) =@@ -231,12 +224,12 @@ sendUserTypingAction | otherwise -> return () - csEditState.cedCompleter .= Nothing-+ checkForAutocompletion liftIO $ resetSpellCheckTimer $ st^.csEditState --- | Send the user_typing action to the server asynchronously, over the connected websocket.--- | If the websocket is not connected, drop the action silently.+-- | 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@@ -272,7 +265,7 @@ allMistakes = S.fromList $ concat $ getMistakes <$> responses csEditState.cedMisspellings .= allMistakes - tryMM query (return . postMistakes)+ tryMM query (return . Just . postMistakes) editorEmpty :: Editor Text a -> Bool editorEmpty e = cursorIsAtEnd e &&@@ -316,3 +309,28 @@ in if numLines > 0 then Z.moveCursor (numLines - 1, lastLineLength) z else z++cancelAutocompleteOrReplyOrEdit :: MH ()+cancelAutocompleteOrReplyOrEdit = do+ 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+ csEditState.cedEditMode .= Replying msg p+ _ -> return ()
src/State/Flagging.hs view
@@ -19,10 +19,11 @@ loadFlaggedMessages :: Seq FlaggedPost -> ChatState -> IO () loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do- return $ sequence_ [ updateMessageFlag (flaggedPostId fp) True- | fp <- toList prefs- , flaggedPostStatus fp- ]+ return $ Just $ do+ sequence_ [ updateMessageFlag (flaggedPostId fp) True+ | fp <- toList prefs+ , flaggedPostStatus fp+ ] -- | Update the UI to reflect the flagged/unflagged state of a
src/State/MessageSelect.hs view
@@ -15,10 +15,8 @@ , deleteSelectedMessage , beginReplyCompose , beginEditMessage- , getSelectedMessage- , cancelReplyOrEdit- , replyToLatestMessage , flagMessage+ , getSelectedMessage ) where @@ -119,7 +117,7 @@ Just curMsg <- use (to getSelectedMessage) let urls = msgURLs curMsg when (not (null urls)) $ do- openedAll <- and <$> mapM openURL urls+ openedAll <- and <$> mapM (openURL . OpenLinkChoice) urls case openedAll of True -> setMode Main False ->@@ -178,8 +176,9 @@ Just p -> doAsyncChannelMM Preempt cId (\s _ _ -> MM.mmDeletePost (postId p) s)- (\_ _ -> do csEditState.cedEditMode .= NewPost- setMode Main)+ (\_ _ -> Just $ do+ csEditState.cedEditMode .= NewPost+ setMode Main) Nothing -> return () _ -> return () @@ -215,25 +214,6 @@ csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany toEdit)) _ -> return () -cancelReplyOrEdit :: MH ()-cancelReplyOrEdit = do- mode <- use (csEditState.cedEditMode)- case mode of- NewPost -> return ()- _ -> do- csEditState.cedEditMode .= NewPost- csEditState.cedEditor %= applyEdit clearZipper--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- csEditState.cedEditMode .= Replying msg p- _ -> return ()- -- | Tell the server that we have flagged or unflagged a message. flagMessage :: PostId -> Bool -> MH () flagMessage pId f = do@@ -242,4 +222,4 @@ doAsyncWith Normal $ do let doFlag = if f then MM.mmFlagPost else MM.mmUnflagPost doFlag myId pId session- return $ return ()+ return Nothing
src/State/Messages.hs view
@@ -7,8 +7,6 @@ , editMessage , deleteMessage , addNewPostedMessage- , addMessageToState- , addObtainedMessages , asyncFetchMoreMessages , fetchVisibleIfNeeded , disconnectChannels@@ -19,6 +17,7 @@ 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@@ -27,7 +26,7 @@ import Graphics.Vty ( outputIface ) import Graphics.Vty.Output.Interface ( ringTerminalBell ) import Lens.Micro.Platform ( Traversal', (.=), (%=), (%~), (.~), (^?)- , to, at, traversed, filtered, ix )+ , to, at, traversed, filtered, ix, _1 ) import Network.Mattermost import qualified Network.Mattermost.Endpoints as MM@@ -60,6 +59,7 @@ 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@@ -83,33 +83,47 @@ lastMsg :: RetrogradeMessages -> Maybe Message lastMsg = withFirstMessage id -sendMessage :: EditMode -> Text -> MH ()-sendMessage mode msg =- case shouldSkipMessage msg of- True -> return ()- False -> do- status <- use csConnectionStatus- st <- use id- case status of- Disconnected -> do- let m = "Cannot send messages while disconnected."- mhError $ GenericError m- Connected -> do- let chanId = st^.csCurrentChannelId- session <- getSession- doAsync Preempt $ do- case mode of+sendMessage :: EditMode -> Text -> [AttachmentData] -> MH ()+sendMessage mode msg attachments =+ when (not $ shouldSkipMessage msg) $ do+ status <- use csConnectionStatus+ st <- use id+ case status of+ Disconnected -> do+ let m = "Cannot send messages while disconnected."+ mhError $ GenericError m+ Connected -> do+ let chanId = st^.csCurrentChannelId+ 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+ 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) }+ let pendingPost = (rawPost msg chanId) { rawPostRootId = postRootId p <|> (Just $ postId p)+ , rawPostFileIds = fileIds+ } void $ MM.mmCreatePost pendingPost session Editing p ty -> do let body = if ty == CP Emote then addEmoteFormatting msg else msg- void $ MM.mmPatchPost (postId p) (postUpdateBody body) session+ update = (postUpdateBody body) { postUpdateFileIds = if null fileIds+ then Nothing+ else Just fileIds+ }+ void $ MM.mmPatchPost (postId p) update session shouldSkipMessage :: Text -> Bool shouldSkipMessage "" = True@@ -119,18 +133,19 @@ editMessage new = do myId <- gets myUserId let isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL)- msg = clientPostToMessage (toClientPost new (new^.postRootIdL))+ (msg, mentionedUsers) = clientPostToMessage (toClientPost new (new^.postRootIdL)) chan = csChannel (new^.postChannelIdL) chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg+ mh $ invalidateCacheEntry (ChannelMessages $ new^.postChannelIdL) + fetchUsersByUsername $ F.toList mentionedUsers+ when (postUserId new /= Just myId) $ chan %= adjustEditedThreshold new csPostMap.ix(postId new) .= msg asyncFetchReactionsForPost (postChannelId new) new asyncFetchAttachments new- cId <- use csCurrentChannelId- when (postChannelId new == cId) updateViewed deleteMessage :: Post -> MH () deleteMessage new = do@@ -140,12 +155,11 @@ chan = csChannel (new^.postChannelIdL) chan.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True) chan %= adjustUpdated new- cId <- use csCurrentChannelId- when (postChannelId new == cId) updateViewed+ mh $ invalidateCacheEntry (ChannelMessages $ new^.postChannelIdL) addNewPostedMessage :: PostToAdd -> MH () addNewPostedMessage p =- addMessageToState p >>= postProcessMessageAdd+ addMessageToState True True p >>= postProcessMessageAdd addObtainedMessages :: ChannelId -> Int -> Posts -> MH PostProcessMessageAdd addObtainedMessages cId reqCnt posts = do@@ -209,21 +223,26 @@ -- The post map returned by the server will *already* have -- all thread messages for each post that is part of a- -- thread. By calling messagesFromPosts here, we go ahead and- -- populate the csPostMap with those posts so that below, in+ -- 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.- void $ messagesFromPosts posts+ -- 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.+ (_, mentionedUsers) <- installMessagesFromPosts posts + fetchUsersByUsername $ F.toList mentionedUsers+ -- 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 . OldPost)+ mapM (addMessageToState False False . OldPost) [ (posts^.postsPostsL) HM.! p | p <- toList (posts^.postsOrderL) , not (p `elem` dupPIds)@@ -258,7 +277,7 @@ let unknownUsers = Set.difference inputUserIds knownUserIds if Set.null unknownUsers then return ()- else handleNewUsers $ Seq.fromList $ toList unknownUsers+ else handleNewUsers (Seq.fromList $ toList unknownUsers) (return ()) addUnknownUsers users @@ -273,8 +292,17 @@ -- mention of the user, etc.). This operation has no effect on any -- existing UnknownGap entries and should be called when those are -- irrelevant.-addMessageToState :: PostToAdd -> MH PostProcessMessageAdd-addMessageToState newPostData = do+--+-- The boolean argument 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.+addMessageToState :: Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd+addMessageToState fetchMentionedUsers 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@@ -296,8 +324,8 @@ -- 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 $ return ()- False -> return $ do+ 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@@ -306,9 +334,9 @@ -- triggers a channel refresh.) if chType == Group then applyPreferenceChange pref- else refreshChannel nc member+ else refreshChannel SidebarUpdateImmediate nc member - addMessageToState newPostData >>= postProcessMessageAdd+ addMessageToState fetchMentionedUsers fetchAuthor newPostData >>= postProcessMessageAdd return NoAction Just _ -> do@@ -325,11 +353,24 @@ 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' = clientPostToMessage cp- & mFlagged .~ ((cp^.cpPostId) `Set.member` flags)+ let (msg', mentionedUsers) = clientPostToMessage cp+ & _1.mFlagged .~ ((cp^.cpPostId) `Set.member` flags)++ when fetchMentionedUsers $+ fetchUsersByUsername $ F.toList mentionedUsers+ csPostMap.at(postId new) .= Just msg'+ mh $ invalidateCacheEntry (ChannelMessages cId) csChannels %= modifyChannelById cId ((ccContents.cdMessages %~ addMessage msg') . (adjustUpdated new) .@@ -356,15 +397,7 @@ Nothing -> do doAsyncChannelMM Preempt cId (\s _ _ -> MM.mmGetThread parentId s)- (\_ p -> do- let postMap = HM.fromList [ ( pId- , clientPostToMessage- (toClientPost x (x^.postRootIdL))- )- | (pId, x) <- HM.toList (p^.postsPostsL)- ]- csPostMap %= HM.union postMap- )+ (\_ p -> Just $ updatePostMap p) _ -> return () _ -> return () @@ -420,9 +453,9 @@ postProcessMessageAdd ppma = postOp ppma where postOp NoAction = return ()- postOp UpdateServerViewed = updateViewed+ postOp UpdateServerViewed = updateViewed False postOp (NotifyUser p) = maybeRingBell >> mapM_ maybeNotify p- postOp (NotifyUserAndServer p) = updateViewed >> maybeRingBell >> mapM_ maybeNotify p+ postOp (NotifyUserAndServer p) = updateViewed False >> maybeRingBell >> mapM_ maybeNotify p maybeNotify :: PostToAdd -> MH () maybeNotify (OldPost _) = do@@ -465,13 +498,13 @@ sender = T.unpack $ maybePostUsername st post runLoggedCommand False outputChan (T.unpack cmd) [notified, sender, messageString] Nothing Nothing- return $ return ()+ return Nothing maybePostUsername :: ChatState -> Post -> T.Text maybePostUsername st p = fromMaybe T.empty $ do- uId <- postUserId p- usernameForUserId uId st+ 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@@ -506,60 +539,61 @@ _ -> q in doAsyncChannelMM Preempt cId (\s _ c -> MM.mmGetPostsForChannel c query s)- (\c p -> do addObtainedMessages c (-pageAmount) p >>= postProcessMessageAdd- mh $ invalidateCacheEntry (ChannelMessages cId))+ (\c p -> Just $ do+ addObtainedMessages c (-pageAmount) p >>= postProcessMessageAdd+ mh $ invalidateCacheEntry (ChannelMessages cId)) fetchVisibleIfNeeded :: MH () fetchVisibleIfNeeded = do sts <- use csConnectionStatus- case sts of- 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- in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do- csChannel(cId).ccContents.cdFetchPending .= True- doAsyncChannelMM Preempt cId op- (\c p -> do addObtainedMessages c (-numToReq) p >>= postProcessMessageAdd- csChannel(c).ccContents.cdFetchPending .= False)-- _ -> return ()+ 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+ in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do+ csChannel(cId).ccContents.cdFetchPending .= True+ doAsyncChannelMM Preempt cId op+ (\c p -> Just $ do+ addObtainedMessages c (-numToReq) 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 $- csChannel(cId).ccContents.cdMessages.traversed %= addAttachment+ 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 view
@@ -0,0 +1,11 @@+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/PostListOverlay.hs view
@@ -43,8 +43,8 @@ session <- getSession doAsyncWith Preempt $ do posts <- mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery session- return $ do- messages <- messagesFromPosts posts+ return $ Just $ do+ messages <- fst <$> installMessagesFromPosts posts enterPostListMode PostListFlagged messages -- | Create a PostListOverlay with post search result messages from the@@ -59,8 +59,8 @@ enterPostListMode (PostListSearch terms True) noMessages doAsyncWith Preempt $ do posts <- mmSearchForTeamPosts tId (SearchPosts terms False) session- return $ do- messages <- messagesFromPosts posts+ return $ Just $ do+ messages <- fst <$> installMessagesFromPosts posts enterPostListMode (PostListSearch terms False) messages -- | Move the selection up in the PostListOverlay, which corresponds
src/State/Reactions.hs view
@@ -24,7 +24,7 @@ | not (p^.postHasReactionsL) = return () | otherwise = doAsyncChannelMM Normal cId (\s _ _ -> fmap toList (mmGetReactionsForPost (p^.postIdL) s))- addReactions+ (\_ rs -> Just $ addReactions cId rs) addReactions :: ChannelId -> [Reaction] -> MH () addReactions cId rs = csChannel(cId).ccContents.cdMessages %= fmap upd
src/State/Setup.hs view
@@ -9,14 +9,13 @@ import Brick.BChan import Brick.Themes ( themeToAttrMap, loadCustomizations )-import Control.Concurrent.MVar ( newMVar ) import qualified Control.Concurrent.STM as STM import Control.Exception ( catch ) import Data.Maybe ( fromJust ) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Time.Clock ( getCurrentTime )-import Lens.Micro.Platform ( (%~) )+import Lens.Micro.Platform ( (.~) ) import System.Exit ( exitFailure ) import System.FilePath ( (</>), isRelative, dropFileName ) import System.IO.Error ( catchIOError )@@ -29,6 +28,7 @@ import LastRunState import Login import State.Flagging+import State.Messages ( fetchVisibleIfNeeded ) import State.Setup.Threads import TeamSelect import Themes@@ -134,8 +134,7 @@ Nothing -> interactiveTeamSelection (toList teams) Just t -> return t - userStatusLock <- newMVar ()- userIdSet <- STM.atomically $ STM.newTVar mempty+ userStatusChan <- STM.newTChanIO slc <- STM.newTChanIO wac <- STM.newTChanIO @@ -169,9 +168,21 @@ requestChan <- STM.atomically STM.newTChan - let cr = ChatResources session cd requestChan eventChan- slc wac (themeToAttrMap custTheme) userStatusLock- userIdSet config mempty userPrefs mempty logMgr+ 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+ } st <- initializeState cr myTeam me @@ -203,7 +214,6 @@ -- 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.- -- This is not entirely correct since the Town Square channel can be renamed! userChans <- mmGetChannelsForUser UserMe myTId session let lastSelectedChans = Seq.filter isLastSelectedChannel userChans chans = if Seq.null lastSelectedChans@@ -212,8 +222,8 @@ -- Since the only channel we are dealing with is by construction the -- last channel, we don't have to consider other cases here:- msgs <- forM (toList chans) $ \c -> do- cChannel <- makeClientChannel c+ chanPairs <- forM (toList chans) $ \c -> do+ cChannel <- makeClientChannel (userId me) c return (getId c, cChannel) tz <- lookupLocalTimeZone@@ -232,8 +242,8 @@ -- * Main async queue worker thread startAsyncWorkerThread (cr^.crConfiguration) (cr^.crRequestQueue) (cr^.crEventQueue) - -- * User status refresher- startUserRefreshThread (cr^.crUserIdSet) (cr^.crUserStatusLock) session requestChan+ -- * User status thread+ startUserStatusUpdateThread (cr^.crStatusUpdateChan) session requestChan -- * Refresher for users who are typing currently when (configShowTypingIndicator (cr^.crConfiguration)) $@@ -250,9 +260,10 @@ -- End thread startup ---------------------------------------------- - let names = mkNames me mempty chans- chanIds = getChannelIdsInOrder names+ now <- getCurrentTime+ let chanIds = mkChannelZipperList now Nothing (cr^.crUserPreferences) clientChans noUsers chanZip = Z.fromList chanIds+ clientChans = foldr (uncurry addChannel) noChannels chanPairs startupState = StartupStateInfo { startupStateResources = cr , startupStateChannelZipper = chanZip@@ -261,14 +272,18 @@ , startupStateTimeZone = tz , startupStateInitialHistory = hist , startupStateSpellChecker = spResult- , startupStateNames = names }- st = newState startupState- & csChannels %~ flip (foldr (uncurry addChannel)) msgs + 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 view
@@ -1,8 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module State.Setup.Threads- ( startUserRefreshThread+ ( startUserStatusUpdateThread , startTypingUsersRefreshThread- , updateUserStatuses , startSubprocessLoggerThread , startTimezoneMonitorThread , maybeStartSpellChecker@@ -16,13 +15,14 @@ import Prelude.MH import Brick.BChan-import Control.Concurrent ( threadDelay, forkIO, MVar, putMVar, tryTakeMVar )+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, finally, fromException )-import qualified Data.Foldable as F+import Control.Exception ( SomeException, try, fromException ) 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 )@@ -31,6 +31,7 @@ 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.Endpoints@@ -41,35 +42,41 @@ import State.Setup.Threads.Logging import TimeUtils ( lookupLocalTimeZone ) import Types+import qualified Zipper as Z -updateUserStatuses :: STM.TVar (Seq UserId) -> MVar () -> Session -> IO (MH ())-updateUserStatuses usersVar lock session = do- lockResult <- tryTakeMVar lock- users <- STM.atomically $ STM.readTVar usersVar-- case lockResult of- Just () | not (F.null users) -> do- statuses <- mmGetUserStatusByIds users session `finally` putMVar lock ()- return $ do- forM_ statuses $ \s ->- setUserStatus (statusUserId s) (statusStatus s)- Just () -> putMVar lock () >> return (return ())- _ -> return $ return ()+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 -startUserRefreshThread :: STM.TVar (Seq UserId) -> MVar () -> Session -> RequestChan -> IO ()-startUserRefreshThread usersVar lock session requestChan = void $ forkIO $ forever refresh+startUserStatusUpdateThread :: STM.TChan (Z.Zipper ChannelListGroup ChannelListEntry) -> Session -> RequestChan -> IO ()+startUserStatusUpdateThread zipperChan session requestChan = void $ forkIO body where seconds = (* (1000 * 1000)) userRefreshInterval = 30- refresh = do- STM.atomically $ STM.writeTChan requestChan $ do- rs <- try $ updateUserStatuses usersVar lock session- case rs of- Left (_ :: SomeException) -> return (return ())- Right upd -> return upd- threadDelay (seconds userRefreshInterval)+ body = refresh []+ refresh prev = do+ result <- timeout (seconds userRefreshInterval) (STM.atomically $ STM.readTChan zipperChan)+ let (uIds, update) = case result of+ Nothing -> (prev, True)+ Just z -> let ids = userIdsFromZipper z+ in (ids, ids /= prev) + 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 ()@@ -78,7 +85,7 @@ seconds = (* (1000 * 1000)) refreshIntervalMicros = ceiling $ seconds $ userTypingExpiryInterval / 2 refresh = do- STM.atomically $ STM.writeTChan requestChan $ return $ 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@@ -119,7 +126,7 @@ hFlush logHandle STM.atomically $ STM.writeTChan requestChan $ do- return $ mhError $ ProgramExecutionFailed (T.pack progName) (T.pack logPath)+ return $ Just $ mhError $ ProgramExecutionFailed (T.pack progName) (T.pack logPath) logMonitor (Just (logPath, logHandle)) @@ -137,13 +144,14 @@ newTz <- lookupLocalTimeZone when (newTz /= prevTz) $ STM.atomically $ STM.writeTChan requestChan $ do- return $ timeZone .= newTz+ 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@@ -216,7 +224,7 @@ -- 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- -- keystroke will trigger another timer anyway.+ -- keystrokes will trigger another timer anyway. expired <- tryWaitDelayIO del case expired of True -> Just <$> newDelay spellCheckTimeout@@ -249,17 +257,18 @@ writeBChan eventChan $ RespEvent $ do csResources.crSyntaxMap .= finalMap+ mh invalidateCache ------------------------------------------------------------------- -- Async worker thread -startAsyncWorkerThread :: Config -> STM.TChan (IO (MH ())) -> BChan MHEvent -> IO ()+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 (MH ())) -> BChan MHEvent -> IO ()+asyncWorker :: Config -> STM.TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO () asyncWorker c r e = forever $ doAsyncWork c r e -doAsyncWork :: Config -> STM.TChan (IO (MH ())) -> BChan MHEvent -> IO ()+doAsyncWork :: Config -> STM.TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO () doAsyncWork config requestChan eventChan = do startWork <- case configShowBackground config of Disabled -> return $ return ()@@ -293,7 +302,9 @@ Just mmErr -> ServerError mmErr writeBChan eventChan $ IEvent $ DisplayError err Right upd ->- writeBChan eventChan (RespEvent upd)+ case upd of+ Nothing -> return ()+ Just action -> writeBChan eventChan (RespEvent action) -- Filter for exceptions that we don't want to report to the user, -- probably because they are not actionable and/or contain no useful@@ -305,6 +316,7 @@ shouldIgnore e = let eStr = show e in or [ "getAddrInfo" `isInfixOf` eStr- , "Network.Socket.recvBuf: timeout" `isInfixOf` eStr+ , "Network.Socket.recvBuf" `isInfixOf` eStr+ , "Network.Socket.sendBuf" `isInfixOf` eStr , "resource vanished" `isInfixOf` eStr ]
src/State/UrlSelect.hs view
@@ -34,7 +34,7 @@ case selected of Nothing -> return () Just (_, link) -> do- opened <- openURL link+ opened <- openURL (OpenLinkChoice link) when (not opened) $ do mhError $ ConfigOptionMissing "urlOpenCommand" setMode Main
src/State/UserListOverlay.hs view
@@ -20,18 +20,18 @@ import qualified Brick.Widgets.Edit as E import qualified Brick.Widgets.List as L-import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.Sequence as Seq import qualified Data.Text as T import qualified Data.Text.Zipper as Z import qualified Data.Vector as Vec-import Lens.Micro.Platform ( (.=), (%=), (.~), to )+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.Channels ( changeChannel, addUserToCurrentChannel )+import State.Channels ( createOrFocusDMChannel, addUserToCurrentChannel ) import State.Common import Types @@ -42,9 +42,10 @@ enterChannelMembersUserList = do cId <- use csCurrentChannelId myId <- gets myUserId- enterUserListMode (ChannelMembers cId)+ myTId <- gets myTeamId+ enterUserListMode (ChannelMembers cId myTId) (\u -> case u^.uiId /= myId of- True -> changeChannel (u^.uiName) >> return True+ True -> createOrFocusDMChannel u >> return True False -> return False ) @@ -55,9 +56,10 @@ enterChannelInviteUserList = do cId <- use csCurrentChannelId myId <- gets myUserId- enterUserListMode (ChannelNonMembers cId)+ myTId <- gets myTeamId+ enterUserListMode (ChannelNonMembers cId myTId) (\u -> case u^.uiId /= myId of- True -> addUserToCurrentChannel (u^.uiName) >> return True+ True -> addUserToCurrentChannel u >> return True False -> return False ) @@ -66,9 +68,14 @@ enterDMSearchUserList :: MH () enterDMSearchUserList = do myId <- gets myUserId- enterUserListMode AllUsers+ myTId <- gets myTeamId+ config <- use csClientConfig+ let restrictTeam = case MM.clientConfigRestrictDirectMessage <$> config of+ Just MM.RestrictTeam -> Just myTId+ _ -> Nothing+ enterUserListMode (AllUsers restrictTeam) (\u -> case u^.uiId /= myId of- True -> changeChannel (u^.uiName) >> return True+ True -> createOrFocusDMChannel u >> return True False -> return False ) @@ -109,10 +116,9 @@ csUserListOverlay.userListSearchResults .= listFromUserSearchResults mempty session <- getSession scope <- use (csUserListOverlay.userListSearchScope)- myTId <- gets myTeamId doAsyncWith Preempt $ do- results <- fetchInitialResults myTId scope session searchString- return $ do+ results <- fetchInitialResults scope session searchString+ return $ Just $ do let lst = listFromUserSearchResults results csUserListOverlay.userListSearchResults .= lst -- NOTE: Disabled for now. See the hack note below for@@ -170,8 +176,8 @@ -- | We'll attempt to prefetch the next page of results if the cursor -- gets within this many positions of the last result we have.-selectionPrefetchDelta :: Int-selectionPrefetchDelta = 10+-- selectionPrefetchDelta :: Int+-- selectionPrefetchDelta = 10 -- Prefetch the next chunk of user list search results if all of the -- following are true:@@ -189,42 +195,42 @@ -- hack note in the getUserSearchResultsPage below for details. In the -- mean time, no pagination of results is possible so no prefetching -- should be done.-_maybePrefetchNextChunk :: MH ()-_maybePrefetchNextChunk = do- gettingMore <- use (csUserListOverlay.userListRequestingMore)- hasAll <- use (csUserListOverlay.userListHasAllResults)- searchString <- userListSearchString- curIdx <- use (csUserListOverlay.userListSearchResults.L.listSelectedL)- numResults <- use (csUserListOverlay.userListSearchResults.to F.length)-- let selectionNearEnd = case curIdx of- Nothing -> False- Just i -> numResults - (i + 1) < selectionPrefetchDelta-- when (not hasAll && T.null searchString && not gettingMore && selectionNearEnd) $ do- let pageNum = numResults `div` searchResultsChunkSize-- csUserListOverlay.userListRequestingMore .= True- session <- getSession- scope <- use (csUserListOverlay.userListSearchScope)- myTId <- gets myTeamId- doAsyncWith Preempt $ do- newChunk <- getUserSearchResultsPage pageNum myTId scope session searchString- return $ do- -- Because we only ever append, this is safe to do w.r.t.- -- the selected index of the list. If we ever prepended or- -- removed, we'd also need to manage the selection index- -- to ensure it stays in bounds.- csUserListOverlay.userListSearchResults.L.listElementsL %= (<> newChunk)- csUserListOverlay.userListRequestingMore .= False-- -- If we got fewer results than we asked for, then we have- -- them all!- --- -- NOTE: disabled for now, see the hack note below.- --- -- csUserListOverlay.userListHasAllResults .=- -- (length newChunk < searchResultsChunkSize)+-- _maybePrefetchNextChunk :: MH ()+-- _maybePrefetchNextChunk = do+-- gettingMore <- use (csUserListOverlay.userListRequestingMore)+-- hasAll <- use (csUserListOverlay.userListHasAllResults)+-- searchString <- userListSearchString+-- curIdx <- use (csUserListOverlay.userListSearchResults.L.listSelectedL)+-- numResults <- use (csUserListOverlay.userListSearchResults.to F.length)+--+-- let selectionNearEnd = case curIdx of+-- Nothing -> False+-- Just i -> numResults - (i + 1) < selectionPrefetchDelta+--+-- when (not hasAll && T.null searchString && not gettingMore && selectionNearEnd) $ do+-- let pageNum = numResults `div` searchResultsChunkSize+--+-- csUserListOverlay.userListRequestingMore .= True+-- session <- getSession+-- scope <- use (csUserListOverlay.userListSearchScope)+-- myTId <- gets myTeamId+-- doAsyncWith Preempt $ do+-- newChunk <- getUserSearchResultsPage pageNum myTId scope session searchString+-- return $ Just $ do+-- -- Because we only ever append, this is safe to do w.r.t.+-- -- the selected index of the list. If we ever prepended or+-- -- removed, we'd also need to manage the selection index+-- -- to ensure it stays in bounds.+-- csUserListOverlay.userListSearchResults.L.listElementsL %= (<> newChunk)+-- csUserListOverlay.userListRequestingMore .= False+--+-- -- If we got fewer results than we asked for, then we have+-- -- them all!+-- --+-- -- NOTE: disabled for now, see the hack note below.+-- --+-- -- csUserListOverlay.userListHasAllResults .=+-- -- (length newChunk < searchResultsChunkSize) -- | The number of users in a "page" for cursor movement purposes. userListPageSize :: Int@@ -232,16 +238,14 @@ -- | Perform an initial request for search results in the specified -- scope.-fetchInitialResults :: TeamId -> UserSearchScope -> Session -> Text -> IO (Vec.Vector UserInfo)+fetchInitialResults :: UserSearchScope -> Session -> Text -> IO (Vec.Vector UserInfo) fetchInitialResults = getUserSearchResultsPage 0 -searchResultsChunkSize :: Int-searchResultsChunkSize = 40+-- searchResultsChunkSize :: Int+-- searchResultsChunkSize = 40 getUserSearchResultsPage :: Int -- ^ The page number of results to fetch, starting at zero.- -> TeamId- -- ^ My team ID. -> UserSearchScope -- ^ The scope to search -> Session@@ -249,7 +253,7 @@ -> Text -- ^ The search string -> IO (Vec.Vector UserInfo)-getUserSearchResultsPage _pageNum myTId scope s searchString = do+getUserSearchResultsPage _pageNum 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.@@ -270,13 +274,16 @@ , userSearchAllowInactive = False , userSearchWithoutTeam = False , userSearchInChannelId = case scope of- ChannelMembers cId -> Just cId- _ -> Nothing+ ChannelMembers cId _ -> Just cId+ _ -> Nothing , userSearchNotInTeamId = Nothing , userSearchNotInChannelId = case scope of- ChannelNonMembers cId -> Just cId- _ -> Nothing- , userSearchTeamId = Just myTId+ 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
src/State/Users.hs view
@@ -1,14 +1,18 @@+{-# LANGUAGE OverloadedStrings #-} module State.Users- (- handleNewUsers+ ( handleNewUsers , handleTypingUser- , handleNewUserDirect+ , UserFetch(..)+ , withFetchedUser+ , withFetchedUserMaybe ) where import Prelude () import Prelude.MH +import qualified Data.Foldable as F+import qualified Data.Sequence as Seq import Data.Time ( getCurrentTime ) import Lens.Micro.Platform @@ -21,27 +25,84 @@ import State.Common -handleNewUsers :: Seq UserId -> MH ()-handleNewUsers newUserIds = doAsyncMM Preempt getUserInfo addNewUsers+handleNewUsers :: Seq UserId -> MH () -> MH ()+handleNewUsers newUserIds after = do+ doAsyncMM Preempt getUserInfo addNewUsers where getUserInfo session _ =- do nUsers <- MM.mmGetUsersByIds newUserIds session+ do nUsers <- MM.mmGetUsersByIds newUserIds session let usrInfo u = userInfoFromUser u True usrList = toList nUsers return $ usrInfo <$> usrList - addNewUsers :: [UserInfo] -> MH ()- addNewUsers = mapM_ addNewUser+ 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- ts <- liftIO getCurrentTime -- get time now- csChannels %= modifyChannelById cId (addChannelTypingUser uId ts)+ config <- use (csResources.crConfiguration)+ when (configShowTypingIndicator config) $ do+ withFetchedUser (UserFetchById uId) $ const $ do+ ts <- liftIO getCurrentTime+ csChannels %= modifyChannelById cId (addChannelTypingUser uId ts) -handleNewUserDirect :: User -> MH ()-handleNewUserDirect newUser = do- let usrInfo = userInfoFromUser newUser True- addNewUser usrInfo+-- | 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)++-- | 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 -> doAsyncWith Normal $ do+ results <- case fetch of+ UserFetchById uId ->+ MM.mmGetUsersByIds (Seq.singleton uId) session+ UserFetchByUsername uname ->+ MM.mmGetUsersByUsernames (Seq.singleton uname) session+ UserFetchByNickname nick -> do+ let req = UserSearch { userSearchTerm = 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/Themes.hs view
@@ -13,6 +13,7 @@ , channelListHeaderAttr , currentChannelNameAttr , unreadChannelAttr+ , unreadGroupMarkerAttr , mentionsChannelAttr , urlAttr , codeAttr@@ -56,6 +57,7 @@ import Brick import Brick.Themes import Brick.Widgets.List+import qualified Brick.Widgets.FileBrowser as FB import Brick.Widgets.Skylighting ( attrNameForTokenType , attrMappingsForStyle , highlightedCodeBlockAttr@@ -131,6 +133,9 @@ unreadChannelAttr :: AttrName unreadChannelAttr = "unreadChannel" +unreadGroupMarkerAttr :: AttrName+unreadGroupMarkerAttr = "unreadChannelGroupMarker"+ mentionsChannelAttr :: AttrName mentionsChannelAttr = "channelWithMentions" @@ -221,6 +226,7 @@ , (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)@@ -252,6 +258,14 @@ , (misspellingAttr, fg red `withStyle` underline) , (editedMarkingAttr, fg yellow) , (editedRecentlyMarkingAttr, 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..] usernameColors) <> (filter skipBaseCodeblockAttr $ attrMappingsForStyle sty)@@ -264,6 +278,7 @@ , (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)@@ -295,6 +310,14 @@ , (misspellingAttr, fg red `withStyle` underline) , (editedMarkingAttr, fg yellow) , (editedRecentlyMarkingAttr, 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..] usernameColors) <> (filter skipBaseCodeblockAttr $ attrMappingsForStyle sty)@@ -355,6 +378,9 @@ , ( 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" )@@ -546,6 +572,36 @@ ) , ( listSelectedFocusedAttr , "The selected channel"+ )+ , ( 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" ) ] <> [ (usernameAttr i, T.pack $ "Username color " <> show i) | i <- [0..(length usernameColors)-1]
src/Types.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} module Types ( ConnectionStatus(..) , HelpTopic(..)@@ -14,10 +15,19 @@ , InternalEvent(..) , Name(..) , ChannelSelectMatch(..)- , MatchValue(..) , StartupStateInfo(..) , MHError(..)+ , AttachmentData(..)+ , OpenInBrowser(..) , ConnectionInfo(..)+ , SidebarUpdate(..)+ , PendingChannelChange(..)+ , clearChannelUnreadStatus+ , ChannelListEntry(..)+ , channelListEntryChannelId+ , channelListEntryUserId+ , userIdsFromZipper+ , entryIsDMEntry , ciHostname , ciPort , ciUsername@@ -34,18 +44,14 @@ , BackgroundInfo(..) , RequestChan - , MMNames- , mkNames- , refreshChannelZipper- , getChannelIdsInOrder+ , mkChannelZipperList+ , ChannelListGroup(..) , trimChannelSigil , ChannelSelectState(..)- , userMatches- , channelMatches+ , channelSelectMatches , channelSelectInput- , selectedMatch , emptyChannelSelectState , ChatState@@ -71,7 +77,7 @@ , csChannelSelectState , csEditState , csClientConfig- , csLastJoinRequest+ , csPendingChannelChange , csViewedMessage , timeZone , whenMode@@ -81,17 +87,29 @@ , ChatEditState , emptyEditState+ , cedAttachmentList+ , cedFileBrowser , cedYankBuffer , cedSpellChecker , cedMisspellings , cedEditMode- , cedCompleter , cedEditor , cedMultiline , cedInputHistory , cedInputHistoryPosition , cedLastChannelInput+ , cedAutocomplete+ , cedAutocompletePending + , AutocompleteState(..)+ , acPreviousSearchString+ , acCompletionList+ , acListElementType+ , acCachedResponses++ , AutocompleteAlternative(..)+ , autocompleteAlternativeReplacement+ , PostListOverlayState , postListSelected , postListPosts@@ -109,15 +127,17 @@ , listFromUserSearchResults - , ChatResources(ChatResources)+ , getUsers++ , ChatResources(..) , crUserPreferences , crEventQueue , crTheme+ , crStatusUpdateChan , crSubprocessLog , crWebsocketActionChan+ , crWebsocketThreadId , crRequestQueue- , crUserStatusLock- , crUserIdSet , crFlaggedPosts , crConn , crConfiguration@@ -130,7 +150,10 @@ , userPrefShowJoinLeave , userPrefFlaggedPostList , userPrefGroupChannelPrefs+ , userPrefDirectChannelPrefs , userPrefTeammateNameDisplayMode+ , dmChannelShowPreference+ , groupChannelShowPreference , defaultUserPreferences , setUserPreferences@@ -168,6 +191,8 @@ , requestLogDestination , sendLogMessage + , isNameFragment+ , requestQuit , clientPostToMessage , getMessageForPostId@@ -176,32 +201,27 @@ , withChannel , withChannelOrDefault , userList+ , resetAutocomplete , hasUnread+ , hasUnread' , isMine , setUserStatus , myUser , myUserId , myTeamId , usernameForUserId- , userIdForUsername- , userByDMChannelName , userByUsername+ , userByNickname , channelIdByChannelName , channelIdByUsername- , channelIdByName , channelByName , userById , allUserIds- , allChannelNames- , allUsernames- , sortedUserList- , removeChannelName- , addChannelName , addNewUser- , setUserIdSet- , channelMentionCount , useNickname- , displaynameForUserId+ , useNickname'+ , displayNameForUserId+ , displayNameForUser , raiseInternalEvent , getNewMessageCutoff , getEditedMessageCutoff@@ -213,6 +233,8 @@ , ChannelSet , getHighlightSet + , takeWhileNameFragment+ , module Types.Channels , module Types.Messages , module Types.Posts@@ -225,28 +247,36 @@ import qualified Brick import Brick ( EventM, Next )+import Brick.Main ( invalidateCache, invalidateCacheEntry ) import Brick.AttrMap ( AttrMap ) import Brick.BChan import Brick.Widgets.Edit ( Editor, editor ) import Brick.Widgets.List ( List, list )+import qualified Brick.Widgets.FileBrowser as FB+import qualified Cheapskate as C+import Control.Concurrent ( ThreadId ) import Control.Concurrent.Async ( Async )-import Control.Concurrent.MVar ( MVar ) import qualified Control.Concurrent.STM as STM import Control.Exception ( SomeException ) import qualified Control.Monad.State as St import qualified Control.Monad.Reader as R+import qualified Data.ByteString as BS+import Data.Char ( isAlpha ) import qualified Data.Foldable as F+import Data.Ord ( comparing ) import qualified Data.HashMap.Strict as HM-import Data.List ( partition, sortBy )+import Data.List ( sortBy, break )+import qualified Data.Set as S import qualified Data.Sequence as Seq-import qualified Data.Set as Set import qualified Data.Text as T-import Data.Time.Clock ( UTCTime, getCurrentTime )+import Data.Time.Clock ( UTCTime, getCurrentTime, nominalDay, addUTCTime ) import Data.UUID ( UUID ) import qualified Data.Vector as Vec import Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=) , (%=), (^?), (.~)- , _Just, Traversal', preuse, (^..), folded, to, view )+ , _Just, Traversal', preuse, to+ , SimpleGetter+ ) import Network.Connection ( HostNotResolved, HostCannotConnect ) import Skylighting.Types ( SyntaxMap ) import System.Exit ( ExitCode )@@ -260,16 +290,15 @@ import Network.Mattermost.Types.Config import Network.Mattermost.WebSocket ( WebsocketEvent ) -import Completion ( Completer ) import InputHistory-import Types.Channels 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, focusL, updateList )+import Zipper ( Zipper, toList, fromList, unsafeFocus ) -- * Configuration@@ -281,6 +310,22 @@ | PasswordCommand Text deriving (Eq, Read, Show) +-- | The type of channel list group headings.+data ChannelListGroup =+ ChannelGroupPublicChannels+ | ChannelGroupDirectMessages+ deriving (Eq)++-- | 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.@@ -360,63 +405,153 @@ -- thread's work queue length. deriving (Eq, Show) --- * 'MMNames' structures+data UserPreferences =+ UserPreferences { _userPrefShowJoinLeave :: Bool+ , _userPrefFlaggedPostList :: Seq FlaggedPost+ , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool+ , _userPrefDirectChannelPrefs :: HashMap UserId Bool+ , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode+ } --- | The 'MMNames' record is for listing human-readable names and--- mapping them back to internal IDs.-data MMNames =- MMNames { _cnChans :: [Text] -- ^ All channel names- , _channelNameToChanId :: HashMap Text ChannelId- -- ^ Mapping from channel names to 'ChannelId' values- , _usernameToChanId :: HashMap Text ChannelId- -- ^ Mapping from user names to 'ChannelId' values. Only- -- contains entries for which DM channel IDs are known.- , _cnUsers :: [Text] -- ^ All users- , _cnToUserId :: HashMap Text UserId- -- ^ Mapping from user names to 'UserId' values- }+hasUnread :: ChatState -> ChannelId -> Bool+hasUnread st cId = fromMaybe False $+ hasUnread' <$> findChannelById cId (_csChannels st) --- | MMNames constructor, seeded with an initial mapping of user ID to--- user and channel metadata.-mkNames :: User -> HashMap UserId User -> Seq Channel -> MMNames-mkNames myUser users chans =- MMNames { _cnChans = sort- [ preferredChannelName c- | c <- toList chans, channelType c /= Direct ]- , _channelNameToChanId = HM.fromList [ (preferredChannelName c, channelId c) | c <- toList chans ]- , _usernameToChanId = HM.fromList $- [ (userUsername u, c)- | u <- HM.elems users- , c <- lookupChan (getDMChannelName (getId myUser) (getId u))- ]- , _cnUsers = sort (map userUsername (HM.elems users))- , _cnToUserId = HM.fromList- [ (userUsername u, getId u) | u <- HM.elems users ]- }- where lookupChan n = [ c^.channelIdL- | c <- toList chans, (sanitizeUserText $ c^.channelNameL) == n- ]+hasUnread' :: ClientChannel -> Bool+hasUnread' chan = fromMaybe False $ do+ let info = _ccInfo chan+ lastViewTime <- _cdViewed info+ return $ ((_cdUpdated info) > lastViewTime) ||+ (isJust $ _cdEditedMessageThreshold info) --- ** 'MMNames' Lenses+mkChannelZipperList :: UTCTime+ -> Maybe ClientConfig+ -> UserPreferences+ -> ClientChannels+ -> Users+ -> [(ChannelListGroup, [ChannelListEntry])]+mkChannelZipperList now cconfig prefs cs us =+ [ (ChannelGroupPublicChannels, getNonDMChannelIdsInOrder cs)+ , (ChannelGroupDirectMessages, getDMChannelsInOrder now cconfig prefs us cs)+ ] -makeLenses ''MMNames+getNonDMChannelIdsInOrder :: ClientChannels -> [ChannelListEntry]+getNonDMChannelIdsInOrder cs =+ let matches (_, info) = info^.ccInfo.cdType `notElem` [Direct, Group]+ in fmap (CLChannel . fst) $+ sortBy (comparing ((^.ccInfo.cdName) . snd)) $+ filteredChannels matches cs --- ** 'MMNames' functions+getDMChannelsInOrder :: UTCTime+ -> Maybe ClientConfig+ -> UserPreferences+ -> Users+ -> ClientChannels+ -> [ChannelListEntry]+getDMChannelsInOrder now cconfig prefs us cs =+ let oneOnOneDmChans = getDMChannels now cconfig prefs us cs+ groupChans = getGroupDMChannels now 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 -mkChannelZipperList :: MMNames -> [ChannelId]-mkChannelZipperList chanNames =- getChannelIdsInOrder chanNames ++- getDMChannelIdsInOrder chanNames+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 -getChannelIdsInOrder :: MMNames -> [ChannelId]-getChannelIdsInOrder n = [ (n ^. channelNameToChanId) HM.! i | i <- n ^. cnChans ]+displayNameForUser :: UserInfo -> Maybe ClientConfig -> UserPreferences -> Text+displayNameForUser u clientConfig prefs+ | useNickname' clientConfig prefs =+ fromMaybe (u^.uiName) (u^.uiNickName)+ | otherwise =+ u^.uiName -getDMChannelIdsInOrder :: MMNames -> [ChannelId]-getDMChannelIdsInOrder n =- [ c | i <- n ^. cnUsers- , c <- maybeToList (HM.lookup i (n ^. usernameToChanId))- ]+getGroupDMChannels :: UTCTime+ -> UserPreferences+ -> ClientChannels+ -> [(Bool, T.Text, ChannelListEntry)]+getGroupDMChannels now prefs cs =+ let matches (_, info) = info^.ccInfo.cdType == Group &&+ groupChannelShouldAppear now prefs info+ in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdName, CLGroupDM cId)) $+ filteredChannels matches cs +getDMChannels :: UTCTime+ -> Maybe ClientConfig+ -> UserPreferences+ -> Users+ -> ClientChannels+ -> [(Bool, T.Text, ChannelListEntry)]+getDMChannels now 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 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 -> UserPreferences -> ClientChannel -> Bool+dmChannelShouldAppear now prefs c =+ let weeksAgo n = nominalDay * (-7 * n)+ localCutoff = addUTCTime (weeksAgo 1) 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 -> UserPreferences -> ClientChannel -> Bool+groupChannelShouldAppear now prefs c =+ let weeksAgo n = nominalDay * (-7 * n)+ localCutoff = addUTCTime (weeksAgo 1) 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@@ -433,12 +568,17 @@ | KeybindingHelpText | ChannelSelectString | CompletionAlternatives+ | CompletionList | JoinChannelList | UrlList | MessagePreviewViewport | UserListSearchInput | UserListSearchResults | ViewMessageArea+ | ChannelSidebar+ | ChannelSelectInput+ | AttachmentList+ | AttachmentFileBrowser deriving (Eq, Show, Ord) -- | The sum type of exceptions we expect to encounter on authentication@@ -463,8 +603,6 @@ , _ciPassword :: Text } -makeLenses ''ConnectionInfo- -- | 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@@ -494,10 +632,14 @@ , 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 =@@ -505,8 +647,8 @@ | Suffix | Infix | Equal- | UsersOnly- | ChannelsOnly+ | PrefixDMOnly+ | PrefixNonDMOnly deriving (Eq, Show) -- * Application State Values@@ -520,18 +662,12 @@ , programExitCode :: ExitCode } -data UserPreferences =- UserPreferences { _userPrefShowJoinLeave :: Bool- , _userPrefFlaggedPostList :: Seq FlaggedPost- , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool- , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode- }- defaultUserPreferences :: UserPreferences defaultUserPreferences = UserPreferences { _userPrefShowJoinLeave = True , _userPrefFlaggedPostList = mempty , _userPrefGroupChannelPrefs = mempty+ , _userPrefDirectChannelPrefs = mempty , _userPrefTeammateNameDisplayMode = Nothing } @@ -542,6 +678,13 @@ 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@@ -629,14 +772,14 @@ -- the application state. data ChatResources = ChatResources { _crSession :: Session+ , _crWebsocketThreadId :: Maybe ThreadId , _crConn :: ConnectionData , _crRequestQueue :: RequestChan , _crEventQueue :: BChan MHEvent , _crSubprocessLog :: STM.TChan ProgramOutput , _crWebsocketActionChan :: STM.TChan WebsocketAction , _crTheme :: AttrMap- , _crUserStatusLock :: MVar ()- , _crUserIdSet :: STM.TVar (Seq UserId)+ , _crStatusUpdateChan :: STM.TChan (Zipper ChannelListGroup ChannelListEntry) , _crConfiguration :: Config , _crFlaggedPosts :: Set PostId , _crUserPreferences :: UserPreferences@@ -644,22 +787,88 @@ , _crLogManager :: LogManager } +data AutocompleteAlternative =+ UserCompletion User Bool+ -- ^ User, plus whether the user is in the channel that triggered+ -- the autocomplete+ | 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 +autocompleteAlternativeReplacement :: AutocompleteAlternative -> Text+autocompleteAlternativeReplacement (UserCompletion u _) =+ userSigil <> userUsername u+autocompleteAlternativeReplacement (ChannelCompletion _ c) =+ normalChannelSigil <> (sanitizeUserText $ channelName c)+autocompleteAlternativeReplacement (SyntaxCompletion t) =+ "```" <> t+autocompleteAlternativeReplacement (CommandCompletion t _ _) =+ "/" <> t++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+ , _acListElementType :: Text+ -- ^ The label (plural noun, e.g. "Users") used to+ -- display the result list to the user+ , _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- , _cedMultiline :: Bool- , _cedInputHistory :: InputHistory+ ChatEditState { _cedEditor :: Editor Text Name+ , _cedEditMode :: EditMode+ , _cedMultiline :: Bool+ , _cedInputHistory :: InputHistory , _cedInputHistoryPosition :: HashMap ChannelId (Maybe Int)- , _cedLastChannelInput :: HashMap ChannelId (Text, EditMode)- , _cedCompleter :: Maybe Completer- , _cedYankBuffer :: Text- , _cedSpellChecker :: Maybe (Aspell, IO ())- , _cedMisspellings :: Set Text+ , _cedLastChannelInput :: HashMap ChannelId (Text, EditMode)+ , _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 :: FB.FileBrowser Name+ -- ^ The browser for selecting attachment files. } +-- | An attachment.+data AttachmentData =+ AttachmentData { attachmentDataFileInfo :: FB.FileInfo+ , attachmentDataBytes :: BS.ByteString+ }+ deriving (Eq, Show, Read)+ -- | The input mode. data EditMode = NewPost@@ -674,23 +883,27 @@ -- | We can initialize a new 'ChatEditState' value with just an edit -- history, which we save locally.-emptyEditState :: InputHistory -> Maybe (Aspell, IO ()) -> ChatEditState-emptyEditState hist sp =- ChatEditState { _cedEditor = editor MessageInput Nothing ""- , _cedMultiline = False- , _cedInputHistory = hist- , _cedInputHistoryPosition = mempty- , _cedLastChannelInput = mempty- , _cedCompleter = Nothing- , _cedEditMode = NewPost- , _cedYankBuffer = ""- , _cedSpellChecker = sp- , _cedMisspellings = mempty- }+emptyEditState :: InputHistory -> Maybe (Aspell, IO ()) -> IO ChatEditState+emptyEditState hist sp = do+ browser <- FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser Nothing+ return ChatEditState { _cedEditor = editor MessageInput Nothing ""+ , _cedMultiline = False+ , _cedInputHistory = hist+ , _cedInputHistoryPosition = mempty+ , _cedLastChannelInput = mempty+ , _cedEditMode = NewPost+ , _cedYankBuffer = ""+ , _cedSpellChecker = sp+ , _cedMisspellings = mempty+ , _cedAutocomplete = Nothing+ , _cedAutocompletePending = Nothing+ , _cedAttachmentList = list AttachmentList mempty 1+ , _cedFileBrowser = browser+ } -- | 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 (MH ()))+type RequestChan = STM.TChan (IO (Maybe (MH ()))) -- | The 'HelpScreen' type represents the set of possible 'Help' -- dialogues we have to choose from.@@ -732,10 +945,12 @@ | PostListOverlay PostListContents | UserListOverlay | ViewMessage+ | ManageAttachments+ | ManageAttachmentsBrowseFiles deriving (Eq) -- | We're either connected or we're not.-data ConnectionStatus = Connected | Disconnected+data ConnectionStatus = Connected | Disconnected deriving (Eq) -- | This is the giant bundle of fields that represents the current -- state of our application at any given time. Some of this should be@@ -744,11 +959,9 @@ ChatState { _csResources :: ChatResources -- ^ Global application-wide resources that don't change -- much.- , _csFocus :: Zipper ChannelId+ , _csFocus :: Zipper ChannelListGroup ChannelListEntry -- ^ The channel sidebar zipper that tracks which channel -- is selected.- , _csNames :: MMNames- -- ^ Mappings between names and user/channel IDs. , _csMe :: User -- ^ The authenticated user. , _csMyTeam :: Team@@ -799,62 +1012,68 @@ -- ^ The state of the user list overlay. , _csClientConfig :: Maybe ClientConfig -- ^ The Mattermost client configuration, as we understand it.- , _csLastJoinRequest :: Maybe ChannelId- -- ^ The most recently-joined channel ID that we look for- -- in an asynchronous join notification, so that we can- -- switch to it in the sidebar.+ , _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 -- ^ Set when the ViewMessage mode is active. The message -- being viewed. } +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 ChannelId+ , startupStateChannelZipper :: Zipper ChannelListGroup ChannelListEntry , startupStateConnectedUser :: User , startupStateTeam :: Team , startupStateTimeZone :: TimeZoneSeries , startupStateInitialHistory :: InputHistory , startupStateSpellChecker :: Maybe (Aspell, IO ())- , startupStateNames :: MMNames } -newState :: StartupStateInfo -> ChatState-newState (StartupStateInfo {..}) =- ChatState { _csResources = startupStateResources- , _csFocus = startupStateChannelZipper- , _csMe = startupStateConnectedUser- , _csMyTeam = startupStateTeam- , _csNames = startupStateNames- , _csChannels = noChannels- , _csPostMap = HM.empty- , _csUsers = noUsers- , _timeZone = startupStateTimeZone- , _csEditState = emptyEditState startupStateInitialHistory startupStateSpellChecker- , _csMode = Main- , _csShowMessagePreview = configShowMessagePreview $ _crConfiguration startupStateResources- , _csShowChannelList = configShowChannelList $ _crConfiguration startupStateResources- , _csChannelSelectState = emptyChannelSelectState- , _csRecentChannel = Nothing- , _csUrlList = list UrlList mempty 2- , _csConnectionStatus = Connected- , _csWorkerIsBusy = Nothing- , _csJoinChannelList = Nothing- , _csMessageSelect = MessageSelectState Nothing- , _csPostListOverlay = PostListOverlayState emptyDirSeq Nothing- , _csUserListOverlay = nullUserListOverlayState- , _csClientConfig = Nothing- , _csLastJoinRequest = Nothing- , _csViewedMessage = Nothing- }+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+ , _csUrlList = list UrlList mempty 2+ , _csConnectionStatus = Connected+ , _csWorkerIsBusy = Nothing+ , _csJoinChannelList = Nothing+ , _csMessageSelect = MessageSelectState Nothing+ , _csPostListOverlay = PostListOverlayState emptyDirSeq Nothing+ , _csUserListOverlay = nullUserListOverlayState+ , _csClientConfig = Nothing+ , _csPendingChannelChange = Nothing+ , _csViewedMessage = Nothing+ } nullUserListOverlayState :: UserListOverlayState nullUserListOverlayState = UserListOverlayState { _userListSearchResults = listFromUserSearchResults mempty , _userListSearchInput = editor UserListSearchInput (Just 1) ""- , _userListSearchScope = AllUsers+ , _userListSearchScope = AllUsers Nothing , _userListSearching = False , _userListRequestingMore = False , _userListHasAllResults = False@@ -867,28 +1086,16 @@ -- in Draw.UserListOverlay. list UserListSearchResults rs 1 --- | A match in channel selection mode. Constructors distinguish--- between channel and user matches to ensure that a match of each type--- is distinct.-data MatchValue =- UserMatch Text- | ChannelMatch Text- deriving (Eq, Show)- -- | The state of channel selection mode. data ChannelSelectState =- ChannelSelectState { _channelSelectInput :: Text- , _channelMatches :: [ChannelSelectMatch]- , _userMatches :: [ChannelSelectMatch]- , _selectedMatch :: Maybe MatchValue+ ChannelSelectState { _channelSelectInput :: Editor Text Name+ , _channelSelectMatches :: Zipper ChannelListGroup ChannelSelectMatch } emptyChannelSelectState :: ChannelSelectState emptyChannelSelectState =- ChannelSelectState { _channelSelectInput = ""- , _channelMatches = mempty- , _userMatches = mempty- , _selectedMatch = Nothing+ ChannelSelectState { _channelSelectInput = editor ChannelSelectInput (Just 1) ""+ , _channelSelectMatches = fromList [] } -- | The state of message selection mode.@@ -915,9 +1122,9 @@ -- | The scope for searching for users in a user list overlay. data UserSearchScope =- ChannelMembers ChannelId- | ChannelNonMembers ChannelId- | AllUsers+ ChannelMembers ChannelId TeamId+ | ChannelNonMembers ChannelId TeamId+ | AllUsers (Maybe TeamId) -- | Actions that can be sent on the websocket to the server. data WebsocketAction =@@ -1099,10 +1306,12 @@ makeLenses ''ChatResources makeLenses ''ChatState makeLenses ''ChatEditState+makeLenses ''AutocompleteState makeLenses ''PostListOverlayState makeLenses ''UserListOverlayState makeLenses ''ChannelSelectState makeLenses ''UserPreferences+makeLenses ''ConnectionInfo getSession :: MH Session getSession = use (csResources.crSession)@@ -1116,10 +1325,12 @@ when (curMode == m) act setMode :: Mode -> MH ()-setMode = (csMode .=)+setMode m = do+ csMode .= m+ mh invalidateCache setMode' :: Mode -> ChatState -> ChatState-setMode' m st = st & csMode .~ m+setMode' m = csMode .~ m appMode :: ChatState -> Mode appMode = _csMode@@ -1131,9 +1342,27 @@ Just (_, reset) -> reset -- ** Utility Lenses-csCurrentChannelId :: Lens' ChatState ChannelId-csCurrentChannelId = csFocus.focusL+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)@@ -1179,66 +1408,38 @@ | otherwise = Nothing setUserStatus :: UserId -> Text -> MH ()-setUserStatus uId t = csUsers %= modifyUserById uId (uiStatus .~ statusFromText t)--nicknameForUserId :: UserId -> ChatState -> Maybe Text-nicknameForUserId uId st = _uiNickName =<< findUserById uId (st^.csUsers)+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- | useNickname st =- nicknameForUserId uId st <|> usernameForUserId uId st- | otherwise =- usernameForUserId uId st-+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 = st^.csNames.cnToUserId.at (trimUserSigil name)+userIdForUsername name st =+ fst <$> (findUserByUsername name $ st^.csUsers) channelIdByChannelName :: Text -> ChatState -> Maybe ChannelId channelIdByChannelName name st =- HM.lookup (trimChannelSigil name) $ st^.csNames.channelNameToChanId---- | Get a channel ID by username or channel name. Returns (channel--- match, user match). Note that this returns multiple results because--- it's possible for there to be a match for both users and channels.--- Note that this function uses sigils on the input to guarantee clash--- avoidance, i.e., that if the user sigil is present in the input,--- only users will be searched. This allows callers (or the user) to--- disambiguate by sigil, which may be necessary in cases where an input--- with no sigil finds multiple matches.-channelIdByName :: Text -> ChatState -> (Maybe ChannelId, Maybe ChannelId)-channelIdByName name st =- let uMatch = channelIdByUsername name st- cMatch = channelIdByChannelName name st- matches =- if | userSigil `T.isPrefixOf` name -> (Nothing, uMatch)- | normalChannelSigil `T.isPrefixOf` name -> (cMatch, Nothing)- | otherwise -> (cMatch, uMatch)- in matches+ let matches (_, cc) = cc^.ccInfo.cdName == (trimChannelSigil name)+ in listToMaybe $ fst <$> filteredChannels matches (st^.csChannels) channelIdByUsername :: Text -> ChatState -> Maybe ChannelId-channelIdByUsername name st =- let userInfos = st^.csUsers.to allUsers- uName = if useNickname st- then- maybe name (view uiName)- $ findUserByNickname userInfos name- else name- nameToChanId = st^.csNames.usernameToChanId- in HM.lookup (trimUserSigil uName) nameToChanId+channelIdByUsername name st = do+ uId <- userIdForUsername name st+ getDmChannelFor uId (st^.csChannels) useNickname :: ChatState -> Bool useNickname st =- let serverSetting = case st^?csClientConfig._Just.to clientConfigTeammateNameDisplay of- Just TMNicknameOrFullname -> Just True- _ -> Nothing- accountSetting = (== TMNicknameOrFullname) <$> st^.csResources.crUserPreferences.userPrefTeammateNameDisplayMode- fallback = False- in fromMaybe fallback $ accountSetting <|> serverSetting+ useNickname' (st^.csClientConfig) (st^.csResources.crUserPreferences) channelByName :: Text -> ChatState -> Maybe ClientChannel channelByName n st = do@@ -1248,87 +1449,106 @@ trimChannelSigil :: Text -> Text trimChannelSigil n | normalChannelSigil `T.isPrefixOf` n = T.tail n- | otherwise = n+ | otherwise = n addNewUser :: UserInfo -> MH () addNewUser u = do csUsers %= addUser u-- let uname = u^.uiName- uid = u^.uiId- csNames.cnUsers %= (sort . (uname:))- csNames.cnToUserId.at uname .= Just uid+ -- Invalidate the cache because channel message rendering may need+ -- to get updated if this user authored posts in any channels.+ mh invalidateCache - userSet <- use (csResources.crUserIdSet)- St.liftIO $ STM.atomically $ STM.modifyTVar userSet $ (uid Seq.<|)+data SidebarUpdate =+ SidebarUpdateImmediate+ | SidebarUpdateDeferred+ deriving (Eq, Show) -setUserIdSet :: Seq UserId -> MH ()-setUserIdSet ids = do- userSet <- use (csResources.crUserIdSet)- St.liftIO $ STM.atomically $ STM.writeTVar userSet ids+isValidNameChar :: Char -> Bool+isValidNameChar c = isAlpha c || c == '_' || c == '.' || c == '-' -addChannelName :: Type -> ChannelId -> Text -> MH ()-addChannelName chType cid name = do- case chType of- Direct -> csNames.usernameToChanId.at(name) .= Just cid- _ -> csNames.channelNameToChanId.at(name) .= Just cid+isNameFragment :: C.Inline -> Bool+isNameFragment (C.Str t) =+ not (T.null t) && isValidNameChar (T.head t)+isNameFragment _ = False - -- For direct channels the username is already in the user list so- -- do nothing- existingNames <- St.gets allChannelNames- when (chType /= Direct && (not $ name `elem` existingNames)) $- csNames.cnChans %= (sort . (name:))+-- | 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 Text)+clientPostToMessage cp = (m, usernames)+ where+ usernames = findUsernames $ cp^.cpText+ m = Message { _mText = cp^.cpText+ , _mMarkdownSource = cp^.cpMarkdownSource+ , _mUser =+ case cp^.cpUserOverride of+ Just n | cp^.cpType == NormalPost -> UserOverride (n <> "[BOT]")+ _ -> maybe NoUser UserI $ 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+ , _mChannelId = Just $ cp^.cpChannelId+ } -channelMentionCount :: ChannelId -> ChatState -> Int-channelMentionCount cId st =- maybe 0 id (st^?csChannel(cId).ccInfo.cdMentionCount)+resetAutocomplete :: MH ()+resetAutocomplete = do+ csEditState.cedAutocomplete .= Nothing+ csEditState.cedAutocompletePending .= Nothing -allChannelNames :: ChatState -> [Text]-allChannelNames st = st^.csNames.cnChans+findUsernames :: C.Blocks -> S.Set Text+findUsernames = S.unions . F.toList . fmap blockFindUsernames -allUsernames :: ChatState -> [Text]-allUsernames st = st^.csNames.cnChans+blockFindUsernames :: C.Block -> S.Set Text+blockFindUsernames (C.Para is) =+ inlineFindUsernames $ F.toList is+blockFindUsernames (C.Header _ is) =+ inlineFindUsernames $ F.toList is+blockFindUsernames (C.Blockquote bs) =+ findUsernames bs+blockFindUsernames (C.List _ _ bs) =+ S.unions $ F.toList $ findUsernames <$> bs+blockFindUsernames _ =+ mempty -removeChannelName :: Text -> MH ()-removeChannelName name = do- -- Flush cnToChanId- csNames.channelNameToChanId.at name .= Nothing- -- Flush cnChans- csNames.cnChans %= filter (/= name)+inlineFindUsernames :: [C.Inline] -> S.Set Text+inlineFindUsernames [] = mempty+inlineFindUsernames (C.Str "@" : rest) =+ let (strs, remaining) = takeWhileNameFragment rest+ in if null strs+ then inlineFindUsernames remaining+ else S.insert (T.concat $ getInlineStr <$> strs) $ inlineFindUsernames remaining+inlineFindUsernames (_ : rest) =+ inlineFindUsernames rest --- Rebuild the channel zipper contents from the current names collection.-refreshChannelZipper :: MH ()-refreshChannelZipper = do- -- We should figure out how to do this better: this adds it to the- -- channel zipper in such a way that we don't ever change our focus- -- to something else, which is kind of silly- names <- use csNames- let newZip = updateList (mkChannelZipperList names)- csFocus %= newZip+getInlineStr :: C.Inline -> T.Text+getInlineStr (C.Str s) = s+getInlineStr _ = "" -clientPostToMessage :: ClientPost -> Message-clientPostToMessage cp =- Message { _mText = cp^.cpText- , _mMarkdownSource = cp^.cpMarkdownSource- , _mUser =- case cp^.cpUserOverride of- Just n | cp^.cpType == NormalPost -> UserOverride (n <> "[BOT]")- _ -> maybe NoUser UserI $ 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- , _mChannelId = Just $ cp^.cpChannelId- }+takeWhileNameFragment :: [C.Inline] -> ([C.Inline], [C.Inline])+takeWhileNameFragment [] = ([], [])+takeWhileNameFragment rest =+ let (strs, remaining) = break (not . isNameFragment) rest+ -- Does the last element in strs start with a letter? If+ -- not, move it to the remaining list. This avoids pulling+ -- punctuation-only tokens into usernames, e.g. "Hello,+ -- @foobar."+ (strs', remaining') =+ if length strs <= 1+ then (strs, remaining)+ else let (initStrs, [lastStr]) = splitAt (length strs - 1) strs+ in if isAlpha $ T.head $ getInlineStr lastStr+ then (strs, remaining)+ else (initStrs, lastStr : remaining)+ in (strs', remaining') -- * Slash Commands @@ -1358,13 +1578,6 @@ -- * Channel Updates and Notifications -hasUnread :: ChatState -> ChannelId -> Bool-hasUnread st cId = maybe False id $ do- chan <- findChannelById cId (st^.csChannels)- lastViewTime <- chan^.ccInfo.cdViewed- return $ (chan^.ccInfo.cdUpdated > lastViewTime) ||- (isJust $ chan^.ccInfo.cdEditedMessageThreshold)- userList :: ChatState -> [UserInfo] userList st = filter showUser $ allUsers (st^.csUsers) where showUser u = not (isSelf u) && (u^.uiInTeam)@@ -1373,6 +1586,10 @@ 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) @@ -1385,41 +1602,24 @@ myUser :: ChatState -> User myUser st = st^.csMe -userByDMChannelName :: Text- -- ^ the dm channel name- -> UserId- -- ^ me- -> ChatState- -> Maybe UserInfo- -- ^ you-userByDMChannelName name self st =- findUserByDMChannelName (st^.csUsers) name self-+-- 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- uId <- userIdForUsername name st- userById uId st+ snd <$> (findUserByUsername name $ st^.csUsers) -sortedUserList :: ChatState -> [UserInfo]-sortedUserList st = sortBy cmp yes <> sortBy cmp no- where- cmp = compareUserInfo uiName- dmHasUnread u =- case st^.csNames.usernameToChanId.at(u^.uiName) of- Nothing -> False- Just cId- | (st^.csCurrentChannelId) == cId -> False- | otherwise -> hasUnread st cId- (yes, no) = partition dmHasUnread (filter (not . _uiDeleted) $ userList st)+-- 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) -compareUserInfo :: (Ord a) => Lens' UserInfo a -> UserInfo -> UserInfo -> Ordering-compareUserInfo field u1 u2- | u1^.uiStatus == Offline && u2^.uiStatus /= Offline =- GT- | u1^.uiStatus /= Offline && u2^.uiStatus == Offline =- LT- | otherwise =- (u1^.field) `compare` (u2^.field)+getUsers :: MH Users+getUsers = use csUsers -- * HighlightSet @@ -1436,8 +1636,8 @@ getHighlightSet :: ChatState -> HighlightSet getHighlightSet st =- HighlightSet { hUserSet = Set.fromList (st^..csUsers.to allUsers.folded.uiName)- , hChannelSet = Set.fromList (st^..csChannels.folded.ccInfo.cdName)+ HighlightSet { hUserSet = getUsernameSet $ st^.csUsers+ , hChannelSet = getChannelNameSet $ st^.csChannels , hSyntaxMap = st^.csResources.crSyntaxMap } @@ -1450,3 +1650,14 @@ 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 view
@@ -15,13 +15,14 @@ -- * Lenses created for accessing ChannelInfo fields , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated , cdName, cdHeader, cdPurpose, cdType- , cdMentionCount, cdTypingUsers+ , cdMentionCount, cdTypingUsers, cdDMUserId, cdChannelId+ , cdSidebarShowOverride -- * Lenses created for accessing ChannelContents fields , cdMessages, cdFetchPending -- * Creating ClientChannel objects , makeClientChannel -- * Managing ClientChannel collections- , noChannels, addChannel, findChannelById, modifyChannelById+ , noChannels, addChannel, removeChannel, findChannelById, modifyChannelById , channelByIdL, maybeChannelByIdL , filteredChannelIds , filteredChannels@@ -41,6 +42,9 @@ , preferredChannelName , isTownSquare , channelDeleted+ , getDmChannelFor+ , allDmChannelMappings+ , getChannelNameSet ) where @@ -48,6 +52,7 @@ import Prelude.MH import qualified Data.HashMap.Strict as HM+import qualified Data.Set as S import Lens.Micro.Platform ( (%~), (.~), Traversal', Lens' , makeLenses, ix, at , to, non )@@ -96,10 +101,11 @@ | NewPostsStartingAt ServerTime deriving (Eq, Show) -initialChannelInfo :: Channel -> ChannelInfo-initialChannelInfo chan =+initialChannelInfo :: UserId -> Channel -> ChannelInfo+initialChannelInfo myId chan = let updated = chan ^. channelLastPostAtL- in ChannelInfo { _cdViewed = Nothing+ in ChannelInfo { _cdChannelId = chan^.channelIdL+ , _cdViewed = Nothing , _cdNewMessageIndicator = Hide , _cdEditedMessageThreshold = Nothing , _cdMentionCount = 0@@ -110,6 +116,11 @@ , _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@@ -154,7 +165,9 @@ -- | The 'ChannelInfo' record represents metadata -- about a channel data ChannelInfo = ChannelInfo- { _cdViewed :: Maybe ServerTime+ { _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.@@ -176,6 +189,13 @@ -- ^ 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@@ -192,11 +212,11 @@ -- ** Miscellaneous channel operations -makeClientChannel :: (MonadIO m) => Channel -> m ClientChannel-makeClientChannel nc = emptyChannelContents >>= \contents ->+makeClientChannel :: (MonadIO m) => UserId -> Channel -> m ClientChannel+makeClientChannel myId nc = emptyChannelContents >>= \contents -> return ClientChannel { _ccContents = contents- , _ccInfo = initialChannelInfo nc+ , _ccInfo = initialChannelInfo myId nc } canLeaveChannel :: ChannelInfo -> Bool@@ -205,8 +225,12 @@ -- ** Manage the collection of all Channels -- | Define a binary kinded type to allow derivation of functor.-newtype AllMyChannels a = AllChannels { _ofChans :: HashMap ChannelId a }- deriving (Functor, Foldable, Traversable)+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.@@ -214,45 +238,71 @@ makeLenses ''AllMyChannels +getChannelNameSet :: ClientChannels -> S.Set Text+getChannelNameSet = _channelNameSet+ -- | Initial collection of Channels with no members noChannels :: ClientChannels-noChannels = AllChannels HM.empty+noChannels = AllChannels HM.empty HM.empty mempty -- | Add a channel to the existing collection. addChannel :: ChannelId -> ClientChannel -> ClientChannels -> ClientChannels-addChannel cId cinfo = AllChannels . HM.insert cId cinfo . _ofChans+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 . _ofChans+findChannelById cId = HM.lookup cId . _chanMap --- | Extract a specific channel from the collection and perform an--- endomorphism operation on it, then put it back into the collection.+-- | Transform the specified channel in place with provided function. modifyChannelById :: ChannelId -> (ClientChannel -> ClientChannel) -> ClientChannels -> ClientChannels-modifyChannelById cId f = ofChans.ix(cId) %~ f+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 = ofChans . ix cId+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 = ofChans . at cId+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^.ofChans))+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 -> ClientChannels-filteredChannels f cc =- AllChannels . HM.fromList . filter f $ cc^.ofChans.to HM.toList+ -> ClientChannels -> [(ChannelId, ClientChannel)]+filteredChannels f cc = filter f $ cc^.chanMap.to HM.toList ------------------------------------------------------------------------
src/Types/Common.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE MultiWayIf #-} module Types.Common ( sanitizeUserText , sanitizeUserText' , sanitizeChar+ , userIdForDMChannel ) where @@ -10,7 +12,7 @@ import qualified Data.Text as T -import Network.Mattermost.Types ( UserText, unsafeUserText )+import Network.Mattermost.Types ( UserText, unsafeUserText, UserId(..), Id(..) ) sanitizeUserText :: UserText -> T.Text sanitizeUserText = sanitizeUserText' . unsafeUserText@@ -24,3 +26,21 @@ sanitizeChar '\ESC' = "<ESC>" sanitizeChar '\t' = " " sanitizeChar c = T.singleton c++-- | 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/KeyEvents.hs view
@@ -51,6 +51,7 @@ | ToggleMultiLineEvent | EnterFlaggedPostsEvent | ToggleChannelListVisibleEvent+ | ShowAttachmentListEvent -- generic cancel | CancelEvent@@ -86,6 +87,11 @@ | DeleteMessageEvent | EditMessageEvent | ReplyMessageEvent++ -- Attachments+ | AttachmentListAddEvent+ | AttachmentListDeleteEvent+ | AttachmentOpenEvent deriving (Eq, Show, Ord, Enum) allEvents :: [KeyEvent]@@ -107,6 +113,8 @@ , NextUnreadUserOrChannelEvent , LastChannelEvent + , ShowAttachmentListEvent+ , EnterFlaggedPostsEvent , ToggleChannelListVisibleEvent , ShowHelpEvent@@ -138,6 +146,9 @@ , DeleteMessageEvent , EditMessageEvent , ReplyMessageEvent+ , AttachmentListAddEvent+ , AttachmentListDeleteEvent+ , AttachmentOpenEvent ] eventToBinding :: Vty.Event -> Binding@@ -292,6 +303,8 @@ NextUnreadUserOrChannelEvent -> "focus-next-unread-user-or-channel" LastChannelEvent -> "focus-last-channel" + ShowAttachmentListEvent -> "show-attachment-list"+ EnterFlaggedPostsEvent -> "show-flagged-posts" ToggleChannelListVisibleEvent -> "toggle-channel-list-visibility" ShowHelpEvent -> "show-help"@@ -323,3 +336,7 @@ DeleteMessageEvent -> "delete-message" EditMessageEvent -> "edit-message" ReplyMessageEvent -> "reply-message"++ AttachmentListAddEvent -> "add-to-attachment-list"+ AttachmentListDeleteEvent -> "delete-from-attachment-list"+ AttachmentOpenEvent -> "open-attachment"
src/Types/Users.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE DeriveFunctor #-} module Types.Users@@ -13,17 +12,15 @@ -- * Creating UserInfo objects , userInfoFromUser -- * Miscellaneous+ , getUsernameSet , userSigil , trimUserSigil , statusFromText , findUserById- , findUserByName- , findUserByDMChannelName+ , findUserByUsername , findUserByNickname , noUsers, addUser, allUsers , modifyUserById- , getDMChannelName- , userIdForDMChannel , userDeleted , TypingUsers , noTypingUsers@@ -38,12 +35,12 @@ 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 ( Id(Id), UserId(..), User(..)- , idString )+import Network.Mattermost.Types ( UserId(..), User(..) ) import Types.Common @@ -108,8 +105,11 @@ -- ** Manage the collection of all Users -- | Define a binary kinded type to allow derivation of functor.-newtype AllMyUsers a = AllUsers { _ofUsers :: HashMap UserId a }- deriving Functor+data AllMyUsers a =+ AllUsers { _ofUsers :: HashMap UserId a+ , _usernameSet :: S.Set Text+ }+ deriving Functor makeLenses ''AllMyUsers @@ -117,16 +117,21 @@ -- 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+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 = AllUsers . HM.insert (userinfo^.uiId) userinfo . _ofUsers+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]@@ -139,11 +144,11 @@ -- | Initial collection of TypingUsers with no members noTypingUsers :: TypingUsers-noTypingUsers = AllUsers HM.empty+noTypingUsers = AllUsers HM.empty mempty -- | Add a member to the existing collection of TypingUsers addTypingUser :: UserId -> UTCTime -> TypingUsers -> TypingUsers-addTypingUser uId ts = AllUsers . HM.insertWith (<>) uId (Max ts) . _ofUsers+addTypingUser uId ts = ofUsers %~ HM.insertWith (<>) uId (Max ts) -- | Get a list of all typing users allTypingUsers :: TypingUsers -> [UserId]@@ -153,17 +158,17 @@ -- | Expiry is decided by the given timestamp. expireTypingUsers :: UTCTime -> TypingUsers -> TypingUsers expireTypingUsers expiryTimestamp =- AllUsers . HM.filter (\(Max ts') -> ts' >= expiryTimestamp) . _ofUsers+ 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, not necessarly the presented name. It--- will automatically trim a user sigil from the input.-findUserByName :: Users -> Text -> Maybe (UserId, UserInfo)-findUserByName allusers name =+-- 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@@ -171,11 +176,11 @@ -- | 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 :: [UserInfo] -> Text -> Maybe UserInfo-findUserByNickname uList nick =- find (nickCheck nick) uList- where- nickCheck n = maybe False (== (trimUserSigil n)) . _uiNickName+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 userSigil :: Text userSigil = "@"@@ -189,38 +194,3 @@ -- endomorphism operation on it, then put it back into the collection. modifyUserById :: UserId -> (UserInfo -> UserInfo) -> Users -> Users modifyUserById uId f = ofUsers.ix(uId) %~ f--getDMChannelName :: UserId -> UserId -> Text-getDMChannelName me you = cname- where- [loUser, hiUser] = sort $ idString <$> [ you, me ]- cname = loUser <> "__" <> hiUser---- | 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--findUserByDMChannelName :: Users- -> Text -- ^ the dm channel name- -> UserId -- ^ me- -> Maybe UserInfo -- ^ you-findUserByDMChannelName users dmchan me = listToMaybe- [ user- | u <- HM.keys $ _ofUsers users- , getDMChannelName me u == dmchan- , user <- maybeToList (HM.lookup u $ _ofUsers users)- ]
src/Zipper.hs view
@@ -1,97 +1,119 @@ module Zipper ( Zipper , fromList+ , toList , focus- , focusL+ , unsafeFocus , left , leftL , right , rightL- , findLeft , findRight , maybeFindRight , updateList+ , updateListBy , filterZipper+ , maybeMapZipper+ , isEmpty ) where import Prelude ()-import Prelude.MH+import Prelude.MH hiding (toList) +import Data.Maybe ( fromJust ) import qualified Data.Foldable as F-import Lens.Micro.Platform ( Lens, lens, ix, (.~) )+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)+ } -data Zipper a = Zipper- { zFocus :: Int- , zElems :: [a]- }+instance F.Foldable (Zipper a) where+ foldMap f = foldMap f .+ F.toList .+ mconcat .+ F.toList .+ fmap snd .+ zTrees -instance F.Foldable Zipper where- foldMap f = foldMap f . zElems+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 -> Zipper a-left z = z { zFocus = (zFocus z - 1) `mod` length (zElems z) }+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) (Zipper a) (Zipper a) (Zipper a)+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 -> Zipper a-right z = z { zFocus = (zFocus z + 1) `mod` length (zElems z) }+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) (Zipper a) (Zipper a) (Zipper a)+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 -> a-focus z = zElems z !! zFocus z+focus :: Zipper a b -> Maybe b+focus = C.focus . zRing --- A lens to return the focus element-focusL :: Lens (Zipper a) (Zipper a) a a-focusL = lens focus upd- where upd (Zipper n elems) x = Zipper n (elems & ix(n) .~ x)+unsafeFocus :: Zipper a b -> b+unsafeFocus = fromJust . focus -- Turn a list into a wraparound zipper, focusing on the head-fromList :: [a] -> Zipper a-fromList xs = Zipper { zFocus = 0, zElems = xs }+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 :: (a -> Bool) -> Zipper a -> Zipper a+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 :: (a -> Bool) -> Zipper a -> Maybe (Zipper a)-maybeFindRight f z- | f (focus z) = Just z- | otherwise = go (right z) (zFocus z)- where go zC n- | n == zFocus zC = Nothing- | f (focus zC) = Just zC- | otherwise = go (right zC) n+maybeFindRight :: (b -> Bool) -> Zipper a b -> Maybe (Zipper a b)+maybeFindRight f z = do+ newRing <- C.findRotateTo f (zRing z)+ return z { zRing = newRing } --- Shift the focus until a given element is found, or return the--- same zipper if none applies-findLeft :: (a -> Bool) -> Zipper a -> Zipper a-findLeft f z- | f (focus z) = z- | otherwise = go (left z) (zFocus z)- where go zC n- | n == zFocus zC = zC- | f (focus zC) = zC- | otherwise = go (left zC) n+updateList :: (Eq b) => [(a, [b])] -> Zipper a b -> Zipper a b+updateList newList oldZip = updateListBy (\old b -> old == Just b) newList oldZip -updateList :: (Eq a) => [a] -> Zipper a -> Zipper a-updateList newList oldZip = findLeft (== oldFocus) newZip- where oldFocus = focus oldZip- newZip = oldZip { zElems = newList }+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 -filterZipper :: (Eq a) => (a -> Bool) -> Zipper a -> Zipper a-filterZipper f oldZip = findLeft (== oldFocus) newZip- where oldFocus = focus oldZip- newZip = oldZip { zElems = filter f $ zElems oldZip }+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)+ }