diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -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 diff --git a/notification-scripts/notify b/notification-scripts/notify --- a/notification-scripts/notify +++ b/notification-scripts/notify @@ -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. diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -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) diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -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 diff --git a/src/Completion.hs b/src/Completion.hs deleted file mode 100644 --- a/src/Completion.hs +++ /dev/null @@ -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 diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -6,6 +6,7 @@ , PasswordSource(..) , findConfig , getCredentials + , defaultConfig ) where diff --git a/src/Connection.hs b/src/Connection.hs --- a/src/Connection.hs +++ b/src/Connection.hs @@ -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) diff --git a/src/Draw.hs b/src/Draw.hs --- a/src/Draw.hs +++ b/src/Draw.hs @@ -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 diff --git a/src/Draw/Autocomplete.hs b/src/Draw/Autocomplete.hs new file mode 100644 --- /dev/null +++ b/src/Draw/Autocomplete.hs @@ -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) diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -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 diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -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 diff --git a/src/Draw/ManageAttachments.hs b/src/Draw/ManageAttachments.hs new file mode 100644 --- /dev/null +++ b/src/Draw/ManageAttachments.hs @@ -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) diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -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. -- diff --git a/src/Draw/PostListOverlay.hs b/src/Draw/PostListOverlay.hs --- a/src/Draw/PostListOverlay.hs +++ b/src/Draw/PostListOverlay.hs @@ -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)) <=> diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -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 diff --git a/src/Draw/URLList.hs b/src/Draw/URLList.hs new file mode 100644 --- /dev/null +++ b/src/Draw/URLList.hs @@ -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 diff --git a/src/Draw/UserListOverlay.hs b/src/Draw/UserListOverlay.hs --- a/src/Draw/UserListOverlay.hs +++ b/src/Draw/UserListOverlay.hs @@ -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 diff --git a/src/Draw/Util.hs b/src/Draw/Util.hs --- a/src/Draw/Util.hs +++ b/src/Draw/Util.hs @@ -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) diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -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 diff --git a/src/Events/ChannelScroll.hs b/src/Events/ChannelScroll.hs --- a/src/Events/ChannelScroll.hs +++ b/src/Events/ChannelScroll.hs @@ -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" diff --git a/src/Events/ChannelSelect.hs b/src/Events/ChannelSelect.hs --- a/src/Events/ChannelSelect.hs +++ b/src/Events/ChannelSelect.hs @@ -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 diff --git a/src/Events/Keybindings.hs b/src/Events/Keybindings.hs --- a/src/Events/Keybindings.hs +++ b/src/Events/Keybindings.hs @@ -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) + ] diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -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) diff --git a/src/Events/ManageAttachments.hs b/src/Events/ManageAttachments.hs new file mode 100644 --- /dev/null +++ b/src/Events/ManageAttachments.hs @@ -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 diff --git a/src/KeyMap.hs b/src/KeyMap.hs new file mode 100644 --- /dev/null +++ b/src/KeyMap.hs @@ -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) + ] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -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) diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -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 diff --git a/src/Scripts.hs b/src/Scripts.hs --- a/src/Scripts.hs +++ b/src/Scripts.hs @@ -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 diff --git a/src/State/Async.hs b/src/State/Async.hs --- a/src/State/Async.hs +++ b/src/State/Async.hs @@ -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 diff --git a/src/State/Attachments.hs b/src/State/Attachments.hs new file mode 100644 --- /dev/null +++ b/src/State/Attachments.hs @@ -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 diff --git a/src/State/Autocomplete.hs b/src/State/Autocomplete.hs new file mode 100644 --- /dev/null +++ b/src/State/Autocomplete.hs @@ -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 diff --git a/src/State/ChannelSelect.hs b/src/State/ChannelSelect.hs --- a/src/State/ChannelSelect.hs +++ b/src/State/ChannelSelect.hs @@ -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 diff --git a/src/State/Channels.hs b/src/State/Channels.hs --- a/src/State/Channels.hs +++ b/src/State/Channels.hs @@ -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 diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -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) diff --git a/src/State/Editing.hs b/src/State/Editing.hs --- a/src/State/Editing.hs +++ b/src/State/Editing.hs @@ -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 () diff --git a/src/State/Flagging.hs b/src/State/Flagging.hs --- a/src/State/Flagging.hs +++ b/src/State/Flagging.hs @@ -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 diff --git a/src/State/MessageSelect.hs b/src/State/MessageSelect.hs --- a/src/State/MessageSelect.hs +++ b/src/State/MessageSelect.hs @@ -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 diff --git a/src/State/Messages.hs b/src/State/Messages.hs --- a/src/State/Messages.hs +++ b/src/State/Messages.hs @@ -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 diff --git a/src/State/Messages.hs-boot b/src/State/Messages.hs-boot new file mode 100644 --- /dev/null +++ b/src/State/Messages.hs-boot @@ -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 () diff --git a/src/State/PostListOverlay.hs b/src/State/PostListOverlay.hs --- a/src/State/PostListOverlay.hs +++ b/src/State/PostListOverlay.hs @@ -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 diff --git a/src/State/Reactions.hs b/src/State/Reactions.hs --- a/src/State/Reactions.hs +++ b/src/State/Reactions.hs @@ -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 diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -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 diff --git a/src/State/Setup/Threads.hs b/src/State/Setup/Threads.hs --- a/src/State/Setup/Threads.hs +++ b/src/State/Setup/Threads.hs @@ -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 ] diff --git a/src/State/UrlSelect.hs b/src/State/UrlSelect.hs --- a/src/State/UrlSelect.hs +++ b/src/State/UrlSelect.hs @@ -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 diff --git a/src/State/UserListOverlay.hs b/src/State/UserListOverlay.hs --- a/src/State/UserListOverlay.hs +++ b/src/State/UserListOverlay.hs @@ -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 diff --git a/src/State/Users.hs b/src/State/Users.hs --- a/src/State/Users.hs +++ b/src/State/Users.hs @@ -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" diff --git a/src/Themes.hs b/src/Themes.hs --- a/src/Themes.hs +++ b/src/Themes.hs @@ -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] diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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) diff --git a/src/Types/Channels.hs b/src/Types/Channels.hs --- a/src/Types/Channels.hs +++ b/src/Types/Channels.hs @@ -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 ------------------------------------------------------------------------ diff --git a/src/Types/Common.hs b/src/Types/Common.hs --- a/src/Types/Common.hs +++ b/src/Types/Common.hs @@ -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' = "" 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 diff --git a/src/Types/KeyEvents.hs b/src/Types/KeyEvents.hs --- a/src/Types/KeyEvents.hs +++ b/src/Types/KeyEvents.hs @@ -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" diff --git a/src/Types/Users.hs b/src/Types/Users.hs --- a/src/Types/Users.hs +++ b/src/Types/Users.hs @@ -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) - ] diff --git a/src/Zipper.hs b/src/Zipper.hs --- a/src/Zipper.hs +++ b/src/Zipper.hs @@ -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) + }