diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,55 @@ +50200.16.0 +========== + +New features: + * Matterhorn now provides two configuration file settings to control + how typing notifications are used: + * `showTypingIndicator`, which now controls only whether an indicator + is shown when other users are typing, and + * `sendTypingNotifications` (default: `False`), which controls + whether Matterhorn sends typing notifications to the server. + * The channel list sorting mode can now be configured and changed at + runtime. The behavior can be configured by setting + `channelListSorting` in the configuration file to one of the values + below. In addition, a new key event and key binding can cycle through + the available sorting modes: `cycle-channel-list-sorting` (default: + `F4`). The sorting modes are: + * `default` - sort alphabetically with muted channels at the bottom + of each group, and + * `unread-first` - same as default except that unread channels are + displayed at the top of each group. + * The channel list now displays a scroll bar and can be scrolled + independently of the selected channel with these key key events and + bindings: + * `C-Up` / `channel-list-scroll-up` - Scroll up in the channel list + * `C-Down` / `channel-list-scroll-down` - Scroll down in the channel + list + + In addition, the appearance of the scroll bar itself can be customized in + the them using the following attributes: + * `scrollbar` - the base scroll bar attribute + * `scrollbar.handle` - the attribute for the ends (handles) of the + scroll bar + * `scrollbar.trough` - the attribute for the trough (unfilled + portion) of the scroll bar + * Channel list categories can now be collapsed to hide their entries + from view. Matterhorn offers two options for doing this: + * Mouse mode, if enabled, makes the channel list group headings + clickable to toggle their visibility. + * The new `/toggle-sidebar-group` command toggles the visibility of + a specified channel list group. + * The login interface got support for 2FA (second factor + authentication) support. The UI automatically asks for a second + factor if the server requires it. (Thanks msm@tailcall.net!) + +Other enhancements: + * Post links in channel headers can now be clicked if mouse support is + enabled. + * Matterhorn can now be built with GHC up to 9.2. + * The header at the top of the channel list now remains in place while + the channel list is scrolled. + 50200.15.0 ========== @@ -52,6 +103,7 @@ * "reaction" - used for emoji reactions posted by other users, and * "reaction.mine" - used for emoji reactions posted by the current user + This change uses the new attributes for emoji reations rather than emojiAttr ("emoji"). We do this to visually indicate which reactions the current user has contributed to, so that they do not accidentally diff --git a/docs/commands.md b/docs/commands.md --- a/docs/commands.md +++ b/docs/commands.md @@ -7,6 +7,7 @@ | `/attach ` | Attach a given file without browsing | | `/create-channel ` | Create a new public channel | | `/create-private-channel ` | Create a new private channel | +| `/cycle-channel-list-sorting` | Cycle through channel list sorting modes for this team | | `/delete-channel` | Delete the current channel | | `/flags` | Open a window of your flagged posts | | `/focus <~channel>` | Focus on a channel or user | @@ -48,6 +49,8 @@ | `/toggle-expanded-topics` | Toggle expanded channel topics | | `/toggle-favorite` | Toggle the favorite status of the current channel | | `/toggle-message-timestamps` | Toggle message timestamps | +| `/toggle-sidebar-group` | Toggle the visibility of the current channel's sidebar group | +| `/toggle-sidebar-group ` | Toggle the visibility of the named sidebar group | | `/toggle-truncate-verbatim-blocks` | Toggle truncation of verbatim and code blocks | | `/topic` | Set the current channel's topic (header) interactively | | `/topic ` | Set the current channel's topic (header) | diff --git a/docs/keybindings.md b/docs/keybindings.md --- a/docs/keybindings.md +++ b/docs/keybindings.md @@ -3,7 +3,14 @@ # Global Keybindings | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- | -| `F1` | `show-help` | Show this help screen | +| `M-p` | `toggle-message-preview` | Toggle message preview | +| `F2` | `toggle-channel-list-visibility` | Toggle channel list visibility | +| `F3` | `toggle-expanded-channel-topics` | Toggle display of expanded channel topics | +| `C-Right` | `next-team` | Switch to the next available team | +| `C-Left` | `prev-team` | Switch to the previous available team | +| (unbound) | `move-current-team-left` | Move the current team to the left in the team list | +| (unbound) | `move-current-team-right` | Move the current team to the right in the team list | +| `C-q` | `quit` | Quit | # Help Page | Keybinding | Event Name | Description | @@ -19,20 +26,16 @@ # Main Interface | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- | +| `F1` | `show-help` | Show this help screen | | `C-s` | `select-mode` | Select a message to edit/reply/delete | | `C-r` | `reply-recent` | Reply to the most recent message | -| `M-p` | `toggle-message-preview` | Toggle message preview | -| `F2` | `toggle-channel-list-visibility` | Toggle channel list visibility | -| `F3` | `toggle-expanded-channel-topics` | Toggle display of expanded channel topics | -| `C-Right` | `next-team` | Switch to the next available team | -| `C-Left` | `prev-team` | Switch to the previous available team | -| (unbound) | `move-current-team-left` | Move the current team to the left in the team list | -| (unbound) | `move-current-team-right` | Move the current team to the right in the team list | | `M-k` | `invoke-editor` | Invoke `$EDITOR` to edit the current message | | `C-g` | `enter-fast-select` | Enter fast channel selection mode | -| `C-q` | `quit` | Quit | | `Tab` | (non-customizable key) | Tab-complete forward | | `BackTab` | (non-customizable key) | Tab-complete backward | +| `C-Up` | `channel-list-scroll-up` | Scroll up in the channel list | +| `C-Down` | `channel-list-scroll-down` | Scroll down in the channel list | +| `F4` | `cycle-channel-list-sorting` | Cycle through channel list sorting modes | | `Up` | `scroll-up` | Scroll up in the channel input history | | `Down` | `scroll-down` | Scroll down in the channel input history | | `PgUp` | `page-up` | Page up in the channel message list (enters message select mode) | @@ -99,8 +102,8 @@ | `f` | `flag-message` | Flag the selected message | | `v` | `view-message` | View the selected message | | `Enter` | `fetch-for-gap` | Fetch messages for the selected gap | -| `l` | `copy-post-link` | Copy a post's link to the clipboard | | `a` | `react-to-message` | Post a reaction to the selected message | +| `l` | `copy-post-link` | Copy a post's link to the clipboard | # User Listings | Keybinding | Event Name | Description | diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 50200.15.0 +version: 50200.16.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 @@ -11,7 +11,7 @@ copyright: ©2016-2019 docs/AUTHORS.txt category: Chat build-type: Simple -cabal-version: >= 1.18 +cabal-version: 1.18 tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3 data-files: syntax/*.xml @@ -85,6 +85,7 @@ Matterhorn.Events.EditNotifyPrefs Matterhorn.Events.Keybindings Matterhorn.Events.LeaveChannelConfirm + Matterhorn.Events.Global Matterhorn.Events.Main Matterhorn.Events.ManageAttachments Matterhorn.Events.MessageSelect @@ -160,8 +161,8 @@ ghc-options: -fhide-source-paths build-depends: base >=4.8 && <5 - , mattermost-api == 50200.11.0 - , base-compat >= 0.9 && < 0.12 + , mattermost-api == 50200.12.0 + , base-compat >= 0.9 && < 0.13 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.7 , split >= 0.2 && < 0.3 @@ -169,14 +170,14 @@ , semigroups >= 0.18 && < 0.20 , connection >= 0.2 && < 0.4 , text >= 1.2 && < 1.3 - , bytestring >= 0.10 && < 0.11 + , bytestring >= 0.10 && < 0.12 , stm >= 2.4 && < 2.6 , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.5 - , brick >= 0.64.1 && < 0.65 + , brick >= 0.68.1 && < 0.69 , brick-skylighting >= 0.2 && < 0.4 - , vty >= 5.33 && < 5.34 + , vty >= 5.35 && < 5.36 , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.11 && < 0.12 @@ -201,7 +202,7 @@ , skylighting-core >= 0.12 && < 0.13 , timezone-olson >= 0.2 && < 0.3 , timezone-series >= 0.1.6.1 && < 0.2 - , aeson >= 1.2.3.0 && < 1.6 + , aeson >= 1.2.3.0 && < 2.1 , async >= 2.2 && < 2.3 , uuid >= 1.3 && < 1.4 , random >= 1.1 && < 1.2 diff --git a/src/Matterhorn/App.hs b/src/Matterhorn/App.hs --- a/src/Matterhorn/App.hs +++ b/src/Matterhorn/App.hs @@ -32,28 +32,30 @@ app :: App ChatState MHEvent Name app = App { appDraw = draw - , appChooseCursor = \s cs -> case s^.csCurrentTeam.tsMode of - Main -> showFirstCursor s cs - ChannelSelect -> showFirstCursor s cs - UserListOverlay -> showFirstCursor s cs - ReactionEmojiListOverlay -> showFirstCursor s cs - ChannelListOverlay -> showFirstCursor s cs - ManageAttachmentsBrowseFiles -> showFirstCursor s cs - ThemeListOverlay -> showFirstCursor s cs - ChannelTopicWindow -> let tId = s^.csCurrentTeamId - in showCursorNamed (ChannelTopicEditor tId) cs - SaveAttachmentWindow _ -> let tId = s^.csCurrentTeamId - in showCursorNamed (AttachmentPathEditor tId) cs - LeaveChannelConfirm -> Nothing - DeleteChannelConfirm -> Nothing - MessageSelect -> Nothing - MessageSelectDeleteConfirm -> Nothing - PostListOverlay _ -> Nothing - ManageAttachments -> Nothing - ViewMessage -> Nothing - ShowHelp _ _ -> Nothing - UrlSelect -> Nothing - EditNotifyPrefs -> Nothing + , appChooseCursor = \s cs -> + case s^.csCurrentTeamId of + Nothing -> showFirstCursor s cs + Just tId -> + case s^.csTeam(tId).tsMode of + Main -> showFirstCursor s cs + ChannelSelect -> showFirstCursor s cs + UserListOverlay -> showFirstCursor s cs + ReactionEmojiListOverlay -> showFirstCursor s cs + ChannelListOverlay -> showFirstCursor s cs + ManageAttachmentsBrowseFiles -> showFirstCursor s cs + ThemeListOverlay -> showFirstCursor s cs + ChannelTopicWindow -> showCursorNamed (ChannelTopicEditor tId) cs + SaveAttachmentWindow _ -> showCursorNamed (AttachmentPathEditor tId) cs + LeaveChannelConfirm -> Nothing + DeleteChannelConfirm -> Nothing + MessageSelect -> Nothing + MessageSelectDeleteConfirm -> Nothing + PostListOverlay _ -> Nothing + ManageAttachments -> Nothing + ViewMessage -> Nothing + ShowHelp _ _ -> Nothing + UrlSelect -> Nothing + EditNotifyPrefs -> Nothing , appHandleEvent = Events.onEvent , appStartEvent = return , appAttrMap = (^.csResources.crTheme) diff --git a/src/Matterhorn/Command.hs b/src/Matterhorn/Command.hs --- a/src/Matterhorn/Command.hs +++ b/src/Matterhorn/Command.hs @@ -99,72 +99,79 @@ commandList = [ Cmd "quit" "Exit Matterhorn" NoArg $ \ () -> requestQuit - , Cmd "right" "Focus on the next channel" NoArg $ \ () -> - nextChannel + , Cmd "right" "Focus on the next channel" NoArg $ \ () -> do + withCurrentTeam nextChannel - , Cmd "left" "Focus on the previous channel" NoArg $ \ () -> - prevChannel + , Cmd "left" "Focus on the previous channel" NoArg $ \ () -> do + withCurrentTeam prevChannel , Cmd "create-channel" "Create a new public channel" - (LineArg "channel name") $ \ name -> - createOrdinaryChannel True name + (LineArg "channel name") $ \ name -> do + withCurrentTeam $ \tId -> + createOrdinaryChannel tId True name , Cmd "create-private-channel" "Create a new private channel" - (LineArg "channel name") $ \ name -> - createOrdinaryChannel False name + (LineArg "channel name") $ \ name -> do + withCurrentTeam $ \tId -> + createOrdinaryChannel tId False name , Cmd "delete-channel" "Delete the current channel" - NoArg $ \ () -> - beginCurrentChannelDeleteConfirm + NoArg $ \ () -> do + withCurrentTeam beginCurrentChannelDeleteConfirm , Cmd "hide" "Hide the current DM or group channel from the channel list" NoArg $ \ () -> do - tId <- use csCurrentTeamId - hideDMChannel =<< use (csCurrentChannelId tId) + withCurrentTeam $ \tId -> + withCurrentChannel tId $ \cId _ -> do + hideDMChannel cId , Cmd "reconnect" "Force a reconnection attempt to the server" NoArg $ \ () -> connectWebsockets , Cmd "members" "Show the current channel's members" - NoArg $ \ () -> - enterChannelMembersUserList + NoArg $ \ () -> do + withCurrentTeam enterChannelMembersUserList - , Cmd "leave" "Leave a normal channel or hide a DM channel" NoArg $ \ () -> - startLeaveCurrentChannel + , Cmd "leave" "Leave a normal channel or hide a DM channel" NoArg $ \ () -> do + withCurrentTeam startLeaveCurrentChannel - , Cmd "join" "Find a channel to join" NoArg $ \ () -> - enterChannelListOverlayMode + , Cmd "join" "Find a channel to join" NoArg $ \ () -> do + withCurrentTeam enterChannelListOverlayMode - , Cmd "join" "Join the specified channel" (ChannelArg NoArg) $ \(n, ()) -> - joinChannelByName n + , Cmd "join" "Join the specified channel" (ChannelArg NoArg) $ \(n, ()) -> do + withCurrentTeam $ \tId -> + joinChannelByName tId n - , Cmd "theme" "List the available themes" NoArg $ \ () -> - enterThemeListMode + , Cmd "theme" "List the available themes" NoArg $ \ () -> do + withCurrentTeam enterThemeListMode , Cmd "theme" "Set the color theme" - (TokenArg "theme" NoArg) $ \ (themeName, ()) -> - setTheme themeName + (TokenArg "theme" NoArg) $ \ (themeName, ()) -> do + withCurrentTeam $ \tId -> + setTheme tId themeName , Cmd "topic" "Set the current channel's topic (header) interactively" - NoArg $ \ () -> - openChannelTopicWindow + NoArg $ \ () -> do + withCurrentTeam openChannelTopicWindow , Cmd "topic" "Set the current channel's topic (header)" - (LineArg "topic") $ \ p -> - if not (T.null p) then setChannelTopic p else return () + (LineArg "topic") $ \ p -> do + withCurrentTeam $ \tId -> + if not (T.null p) then setChannelTopic tId p else return () , Cmd "add-user" "Search for a user to add to the current channel" - NoArg $ \ () -> - enterChannelInviteUserList + NoArg $ \ () -> do + withCurrentTeam enterChannelInviteUserList , Cmd "msg" "Search for a user to enter a private chat" - NoArg $ \ () -> - enterDMSearchUserList + NoArg $ \ () -> do + withCurrentTeam enterDMSearchUserList , Cmd "msg" "Chat with the specified user" - (UserArg NoArg) $ \ (name, ()) -> - changeChannelByName name + (UserArg NoArg) $ \ (name, ()) -> do + withCurrentTeam $ \tId -> + changeChannelByName tId name , Cmd "username-attribute" "Display the attribute used to color the specified username" (UserArg NoArg) $ \ (name, ()) -> @@ -172,12 +179,12 @@ , Cmd "msg" "Go to a user's channel and send the specified message or command" (UserArg $ LineArg "message or command") $ \ (name, msg) -> do - withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do - case foundUser of - Just user -> createOrFocusDMChannel user $ Just $ \cId -> do - tId <- use csCurrentTeamId - handleInputSubmission tId cId msg - Nothing -> mhError $ NoSuchUser name + withCurrentTeam $ \tId -> + withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do + case foundUser of + Just user -> createOrFocusDMChannel tId user $ Just $ \cId -> do + handleInputSubmission tId cId msg + Nothing -> mhError $ NoSuchUser name , Cmd "log-start" "Begin logging debug information to the specified path" (TokenArg "path" NoArg) $ \ (path, ()) -> @@ -200,18 +207,20 @@ getLogDestination , Cmd "add-user" "Add a user to the current channel" - (UserArg NoArg) $ \ (uname, ()) -> - addUserByNameToCurrentChannel uname + (UserArg NoArg) $ \ (uname, ()) -> do + withCurrentTeam $ \tId -> + addUserByNameToCurrentChannel tId uname , Cmd "remove" "Remove a user from the current channel" - (UserArg NoArg) $ \ (uname, ()) -> - removeUserFromCurrentChannel uname + (UserArg NoArg) $ \ (uname, ()) -> do + withCurrentTeam $ \tId -> + removeUserFromCurrentChannel tId uname , Cmd "user" "Show users to initiate a private DM chat channel" -- n.b. this is identical to "msg", but is provided as an -- alternative mental model for useability. - NoArg $ \ () -> - enterDMSearchUserList + NoArg $ \ () -> do + withCurrentTeam enterDMSearchUserList , Cmd "message-preview" "Toggle preview of the current message" NoArg $ \_ -> toggleMessagePreview @@ -228,52 +237,62 @@ , Cmd "toggle-expanded-topics" "Toggle expanded channel topics" NoArg $ \_ -> toggleExpandedChannelTopics + , Cmd "cycle-channel-list-sorting" "Cycle through channel list sorting modes for this team" NoArg $ \_ -> + withCurrentTeam cycleChannelListSortingMode + , Cmd "focus" "Focus on a channel or user" - (ChannelArg NoArg) $ \ (name, ()) -> - changeChannelByName name + (ChannelArg NoArg) $ \ (name, ()) -> do + withCurrentTeam $ \tId -> + changeChannelByName tId name - , Cmd "focus" "Select from available channels" NoArg $ \ () -> - beginChannelSelect + , Cmd "focus" "Select from available channels" NoArg $ \ () -> do + withCurrentTeam beginChannelSelect - , Cmd "help" "Show the main help screen" NoArg $ \ _ -> - showHelpScreen mainHelpTopic + , Cmd "help" "Show the main help screen" NoArg $ \ _ -> do + withCurrentTeam $ \tId -> + showHelpScreen tId mainHelpTopic - , Cmd "shortcuts" "Show keyboard shortcuts" NoArg $ \ _ -> - showHelpScreen mainHelpTopic + , Cmd "shortcuts" "Show keyboard shortcuts" NoArg $ \ _ -> do + withCurrentTeam $ \tId -> + showHelpScreen tId mainHelpTopic , Cmd "help" "Show help about a particular topic" - (TokenArg "topic" NoArg) $ \ (topicName, ()) -> - case lookupHelpTopic topicName of - Nothing -> mhError $ NoSuchHelpTopic topicName - Just topic -> showHelpScreen topic + (TokenArg "topic" NoArg) $ \ (topicName, ()) -> do + withCurrentTeam $ \tId -> + case lookupHelpTopic topicName of + Nothing -> mhError $ NoSuchHelpTopic topicName + Just topic -> showHelpScreen tId topic , Cmd "sh" "List the available shell scripts" NoArg $ \ () -> listScripts , Cmd "group-create" "Create a group chat" - (LineArg (addUserSigil "user" <> " [" <> addUserSigil "user" <> " ...]")) - createGroupChannel + (LineArg (addUserSigil "user" <> " [" <> addUserSigil "user" <> " ...]")) $ \ t -> do + withCurrentTeam $ \tId -> + createGroupChannel tId t , Cmd "sh" "Run a prewritten shell script" (TokenArg "script" (LineArg "message")) $ \ (script, text) -> do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - findAndRunScript cId script text + withCurrentTeam $ \tId -> + withCurrentChannel tId $ \cId _ -> do + findAndRunScript tId cId script text - , Cmd "flags" "Open a window of your flagged posts" NoArg $ \ () -> - enterFlaggedPostListMode + , Cmd "flags" "Open a window of your flagged posts" NoArg $ \ () -> do + withCurrentTeam enterFlaggedPostListMode - , Cmd "pinned-posts" "Open a window of this channel's pinned posts" NoArg $ \ () -> - enterPinnedPostListMode + , Cmd "pinned-posts" "Open a window of this channel's pinned posts" NoArg $ \ () -> do + withCurrentTeam enterPinnedPostListMode - , Cmd "search" "Search for posts with given terms" (LineArg "terms") $ - enterSearchResultPostListMode + , Cmd "search" "Search for posts with given terms" (LineArg "terms") $ \t -> do + withCurrentTeam $ \tId -> + enterSearchResultPostListMode tId t - , Cmd "notify-prefs" "Edit the current channel's notification preferences" NoArg $ \_ -> - enterEditNotifyPrefsMode + , Cmd "notify-prefs" "Edit the current channel's notification preferences" NoArg $ \_ -> do + withCurrentTeam enterEditNotifyPrefsMode - , Cmd "rename-channel-url" "Rename the current channel's URL name" (TokenArg "channel name" NoArg) $ \ (name, _) -> - renameChannelUrl name + , Cmd "rename-channel-url" "Rename the current channel's URL name" (TokenArg "channel name" NoArg) $ \ (name, _) -> do + withCurrentTeam $ \tId -> + renameChannelUrl tId name , Cmd "move-team-left" "Move the currently-selected team to the left in the team list" NoArg $ \_ -> moveCurrentTeamLeft @@ -281,11 +300,19 @@ , Cmd "move-team-right" "Move the currently-selected team to the right in the team list" NoArg $ \_ -> moveCurrentTeamRight - , Cmd "attach" "Attach a given file without browsing" (LineArg "path") $ - attachFileByPath + , Cmd "attach" "Attach a given file without browsing" (LineArg "path") $ \path -> do + withCurrentTeam $ \tId -> + attachFileByPath tId path - , Cmd "toggle-favorite" "Toggle the favorite status of the current channel" NoArg $ \_ -> - toggleChannelFavoriteStatus + , Cmd "toggle-favorite" "Toggle the favorite status of the current channel" NoArg $ \_ -> do + withCurrentTeam toggleChannelFavoriteStatus + + , Cmd "toggle-sidebar-group" "Toggle the visibility of the current channel's sidebar group" NoArg $ \_ -> do + withCurrentTeam toggleCurrentChannelChannelListGroup + + , let names = T.intercalate "|" $ fst <$> channelListGroupNames + in Cmd "toggle-sidebar-group" "Toggle the visibility of the named sidebar group" (LineArg names) $ \name -> do + withCurrentTeam (toggleCurrentChannelChannelListGroupByName name) ] displayUsernameAttribute :: Text -> MH () @@ -295,49 +322,48 @@ postInfoMessage $ "The attribute used for " <> addUserSigil trimmed <> " is " <> (attrNameToConfig an) -execMMCommand :: Text -> Text -> MH () -execMMCommand name rest = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - session <- getSession - em <- use (csCurrentTeam.tsEditState.cedEditMode) - let mc = MM.MinCommand - { MM.minComChannelId = cId - , MM.minComCommand = "/" <> name <> " " <> rest - , MM.minComParentId = case em of - Replying _ p -> Just $ MM.getId p - Editing p _ -> MM.postRootId p - _ -> Nothing - , MM.minComRootId = case em of - Replying _ p -> MM.postRootId p <|> (Just $ MM.postId p) - Editing p _ -> MM.postRootId p - _ -> Nothing - , MM.minComTeamId = tId - } - runCmd = liftIO $ do - void $ MM.mmExecuteCommand mc session - handleHTTP (MM.HTTPResponseException err) = - return (Just (T.pack err)) - -- XXX: this might be a bit brittle in the future, because it - -- assumes the shape of an error message. We might want to - -- think about a better way of discovering this error and - -- reporting it accordingly? - handleCmdErr (MM.MattermostServerError err) = - let (_, msg) = T.breakOn ": " err in - return (Just (T.drop 2 msg)) - handleMMErr (MM.MattermostError - { MM.mattermostErrorMessage = msg }) = - return (Just msg) - errMsg <- liftIO $ (runCmd >> return Nothing) `Exn.catch` handleHTTP - `Exn.catch` handleCmdErr - `Exn.catch` handleMMErr - case errMsg of - Nothing -> return () - Just err -> - mhError $ GenericError ("Error running command: " <> err) +execMMCommand :: MM.TeamId -> Text -> Text -> MH () +execMMCommand tId name rest = do + withCurrentChannel tId $ \cId _ -> do + session <- getSession + em <- use (csTeam(tId).tsEditState.cedEditMode) + let mc = MM.MinCommand + { MM.minComChannelId = cId + , MM.minComCommand = "/" <> name <> " " <> rest + , MM.minComParentId = case em of + Replying _ p -> Just $ MM.getId p + Editing p _ -> MM.postRootId p + _ -> Nothing + , MM.minComRootId = case em of + Replying _ p -> MM.postRootId p <|> (Just $ MM.postId p) + Editing p _ -> MM.postRootId p + _ -> Nothing + , MM.minComTeamId = tId + } + runCmd = liftIO $ do + void $ MM.mmExecuteCommand mc session + handleHTTP (MM.HTTPResponseException err) = + return (Just (T.pack err)) + -- XXX: this might be a bit brittle in the future, because it + -- assumes the shape of an error message. We might want to + -- think about a better way of discovering this error and + -- reporting it accordingly? + handleCmdErr (MM.MattermostServerError err) = + let (_, msg) = T.breakOn ": " err in + return (Just (T.drop 2 msg)) + handleMMErr (MM.MattermostError + { MM.mattermostErrorMessage = msg }) = + return (Just msg) + errMsg <- liftIO $ (runCmd >> return Nothing) `Exn.catch` handleHTTP + `Exn.catch` handleCmdErr + `Exn.catch` handleMMErr + case errMsg of + Nothing -> return () + Just err -> + mhError $ GenericError ("Error running command: " <> err) -dispatchCommand :: Text -> MH () -dispatchCommand cmd = +dispatchCommand :: MM.TeamId -> Text -> MH () +dispatchCommand tId cmd = case unwordHead cmd of Just (x, xs) | matchingCmds <- [ c @@ -345,7 +371,7 @@ , name == x ] -> go [] matchingCmds where go [] [] = do - execMMCommand x xs + execMMCommand tId x xs go errs [] = do let msg = ("error running command /" <> x <> ":\n" <> mconcat [ " " <> e | e <- errs ]) diff --git a/src/Matterhorn/Command.hs-boot b/src/Matterhorn/Command.hs-boot --- a/src/Matterhorn/Command.hs-boot +++ b/src/Matterhorn/Command.hs-boot @@ -2,8 +2,9 @@ import Data.Text ( Text ) +import Network.Mattermost.Types ( TeamId ) import Matterhorn.Types ( MH, Cmd, CmdArgs ) commandList :: [Cmd] printArgSpec :: CmdArgs a -> Text -dispatchCommand :: Text -> MH () +dispatchCommand :: TeamId -> Text -> MH () diff --git a/src/Matterhorn/Config.hs b/src/Matterhorn/Config.hs --- a/src/Matterhorn/Config.hs +++ b/src/Matterhorn/Config.hs @@ -108,6 +108,8 @@ (configShowExpandedChannelTopics defaultConfig) configShowTypingIndicator <- fieldFlagDef "showTypingIndicator" (configShowTypingIndicator defaultConfig) + configSendTypingNotifications <- fieldFlagDef "sendTypingNotifications" + (configSendTypingNotifications defaultConfig) configEnableAspell <- fieldFlagDef "enableAspell" (configEnableAspell defaultConfig) configSyntaxDirs <- fieldDefOf "syntaxDirectories" syntaxDirsField [] @@ -120,6 +122,8 @@ (configActivityBell defaultConfig) configTruncateVerbatimBlocksInt <- fieldDefOf "truncateVerbatimBlockHeight" number (maybe 0 id $ configTruncateVerbatimBlocks defaultConfig) + configChannelListSorting <- fieldDefOf "channelListSorting" + parseChannelListSorting (configChannelListSorting defaultConfig) let configTruncateVerbatimBlocks = case configTruncateVerbatimBlocksInt of i | i <= 0 -> Nothing | otherwise -> Just i @@ -174,7 +178,10 @@ isHostname :: String -> Bool isHostname "" = False isHostname s = - let parts@(h:_) = splitOn "." s + let parts = splitOn "." s + h = case parts of + (p:_) -> p + [] -> error $ "BUG: isHostname: should always get at least one component: " <> show parts in all isHostnameFragment parts && not ("-" `isPrefixOf` h) hostField :: Text -> Either String Text @@ -212,6 +219,16 @@ _ -> Left ("Invalid value " <> show t <> "; must be one of NotifyV1, NotifyV2") +parseChannelListSorting :: Text -> Either String ChannelListSorting +parseChannelListSorting t = + let validValues = [ ("default", ChannelListSortDefault) + , ("unread-first", ChannelListSortUnreadFirst) + ] + in case lookup (T.unpack $ T.toLower t) validValues of + Just s -> Right s + Nothing -> + Left ("Invalid value " <> show t <> "; must be one of " <> intercalate ", " (fst <$> validValues)) + cpuUsagePolicy :: Text -> Either String CPUUsagePolicy cpuUsagePolicy t = case T.toLower t of @@ -273,11 +290,12 @@ , configAspellDictionary = Nothing , configUnsafeUseHTTP = False , configValidateServerCertificate = True - , configChannelListWidth = 20 + , configChannelListWidth = 22 , configLogMaxBufferSize = 200 , configShowOlderEdits = True , configUserKeys = mempty , configShowTypingIndicator = False + , configSendTypingNotifications = False , configHyperlinkingMode = True , configSyntaxDirs = [] , configDirectChannelExpirationDays = 7 @@ -285,6 +303,7 @@ , configDefaultAttachmentPath = Nothing , configChannelListOrientation = ChannelListLeft , configMouseMode = False + , configChannelListSorting = ChannelListSortDefault } findConfig :: Maybe FilePath -> IO (Either String ([String], Config)) @@ -359,7 +378,9 @@ Right (warns, conf) -> do actualPass <- case configPass conf of Just (PasswordCommand cmdString) -> do - let (cmd:rest) = T.unpack <$> T.words cmdString + let (cmd, rest) = case T.unpack <$> T.words cmdString of + (a:as) -> (a, as) + [] -> error $ "BUG: getConfig: got empty command string" output <- convertIOException (readProcess cmd rest "") `catchE` (\e -> throwE $ "Could not execute password command: " <> e) return $ Just $ T.pack (takeWhile (/= '\n') output) @@ -368,7 +389,9 @@ actualToken <- case configToken conf of Just (TokenCommand cmdString) -> do - let (cmd:rest) = T.unpack <$> T.words cmdString + let (cmd, rest) = case T.unpack <$> T.words cmdString of + (a:as) -> (a, as) + [] -> error $ "BUG: getConfig: got empty command string" output <- convertIOException (readProcess cmd rest "") `catchE` (\e -> throwE $ "Could not execute token command: " <> e) return $ Just $ T.pack (takeWhile (/= '\n') output) diff --git a/src/Matterhorn/Draw.hs b/src/Matterhorn/Draw.hs --- a/src/Matterhorn/Draw.hs +++ b/src/Matterhorn/Draw.hs @@ -28,27 +28,32 @@ draw :: ChatState -> [Widget Name] draw st = - case st^.csCurrentTeam.tsMode of - Main -> mainLayers - UrlSelect -> mainLayers - ChannelSelect -> mainLayers - MessageSelect -> mainLayers - MessageSelectDeleteConfirm -> mainLayers - ShowHelp topic _ -> drawShowHelp topic st - ThemeListOverlay -> drawThemeListOverlay st : mainLayers - LeaveChannelConfirm -> drawLeaveChannelConfirm st : mainLayersMonochrome - DeleteChannelConfirm -> drawDeleteChannelConfirm st : mainLayersMonochrome - PostListOverlay contents -> drawPostListOverlay contents st : mainLayersMonochrome - UserListOverlay -> drawUserListOverlay st : mainLayersMonochrome - ChannelListOverlay -> drawChannelListOverlay st : mainLayersMonochrome - ReactionEmojiListOverlay -> drawReactionEmojiListOverlay st : mainLayersMonochrome - ViewMessage -> drawTabbedWindow messageViewWindow st : mainLayersMonochrome - ManageAttachments -> drawManageAttachments st : mainLayersMonochrome - ManageAttachmentsBrowseFiles -> drawManageAttachments st : mainLayersMonochrome - EditNotifyPrefs -> drawNotifyPrefs st : mainLayersMonochrome - ChannelTopicWindow -> drawChannelTopicWindow st : mainLayersMonochrome - SaveAttachmentWindow _ -> drawSaveAttachmentWindow st : mainLayersMonochrome - where - mainLayers = drawMain True st + let mainLayers = drawMain True st mainLayersMonochrome = drawMain False st - messageViewWindow = st^.csCurrentTeam.tsViewedMessage.singular _Just._2 + in case st^.csCurrentTeamId of + Nothing -> + -- ^ Without a team data structure, we just assume Main mode + -- and render a skeletal UI. + mainLayers + Just tId -> + let messageViewWindow = st^.csTeam(tId).tsViewedMessage.singular _Just._2 + in case st^.csTeam(tId).tsMode of + Main -> mainLayers + UrlSelect -> mainLayers + ChannelSelect -> mainLayers + MessageSelect -> mainLayers + MessageSelectDeleteConfirm -> mainLayers + ShowHelp topic _ -> drawShowHelp topic st + ThemeListOverlay -> drawThemeListOverlay st tId : mainLayers + LeaveChannelConfirm -> drawLeaveChannelConfirm st tId : mainLayersMonochrome + DeleteChannelConfirm -> drawDeleteChannelConfirm st tId : mainLayersMonochrome + PostListOverlay contents -> drawPostListOverlay contents st tId : mainLayersMonochrome + UserListOverlay -> drawUserListOverlay st tId : mainLayersMonochrome + ChannelListOverlay -> drawChannelListOverlay st tId : mainLayersMonochrome + ReactionEmojiListOverlay -> drawReactionEmojiListOverlay st tId : mainLayersMonochrome + ViewMessage -> drawTabbedWindow messageViewWindow st tId : mainLayersMonochrome + ManageAttachments -> drawManageAttachments st tId : mainLayersMonochrome + ManageAttachmentsBrowseFiles -> drawManageAttachments st tId : mainLayersMonochrome + EditNotifyPrefs -> drawNotifyPrefs st tId : mainLayersMonochrome + ChannelTopicWindow -> drawChannelTopicWindow st tId : mainLayersMonochrome + SaveAttachmentWindow _ -> drawSaveAttachmentWindow st tId : mainLayersMonochrome diff --git a/src/Matterhorn/Draw/Autocomplete.hs b/src/Matterhorn/Draw/Autocomplete.hs --- a/src/Matterhorn/Draw/Autocomplete.hs +++ b/src/Matterhorn/Draw/Autocomplete.hs @@ -13,7 +13,7 @@ ) import qualified Data.Text as T -import Network.Mattermost.Types ( User(..), Channel(..) ) +import Network.Mattermost.Types ( User(..), Channel(..), TeamId ) import Matterhorn.Constants ( normalChannelSigil ) import Matterhorn.Draw.Util @@ -22,13 +22,13 @@ import Matterhorn.Types.Common ( sanitizeUserText ) -autocompleteLayer :: ChatState -> Widget Name -autocompleteLayer st = - case st^.csCurrentTeam.tsEditState.cedAutocomplete of +autocompleteLayer :: ChatState -> TeamId -> Widget Name +autocompleteLayer st tId = + case st^.csTeam(tId).tsEditState.cedAutocomplete of Nothing -> emptyWidget Just ac -> - renderAutocompleteBox st ac + renderAutocompleteBox st tId ac userNotInChannelMarker :: T.Text userNotInChannelMarker = "*" @@ -40,8 +40,8 @@ elementTypeLabel ACEmoji = "Emoji" elementTypeLabel ACCommands = "Commands" -renderAutocompleteBox :: ChatState -> AutocompleteState -> Widget Name -renderAutocompleteBox st ac = +renderAutocompleteBox :: ChatState -> TeamId -> AutocompleteState -> Widget Name +renderAutocompleteBox st tId ac = let matchList = _acCompletionList ac maxListHeight = 5 visibleHeight = min maxListHeight numResults @@ -53,10 +53,15 @@ " (Tab/Shift-Tab to select)" selElem = snd <$> listSelectedElement matchList - curChan = st^.csCurrentChannel - footer = case renderAutocompleteFooterFor curChan =<< selElem of - Just w -> hBorderWithLabel w - _ -> hBorder + mcId = st^.csCurrentChannelId(tId) + mCurChan = mcId >>= (\cId -> st^?csChannel(cId)) + footer = case mCurChan of + Nothing -> + hBorder + Just curChan -> + case renderAutocompleteFooterFor curChan =<< selElem of + Just w -> hBorderWithLabel w + _ -> hBorder curUser = myUsername st in if numResults == 0 @@ -64,7 +69,7 @@ else Widget Greedy Greedy $ do ctx <- getContext let rowOffset = ctx^.availHeightL - 3 - editorOffset - visibleHeight - editorOffset = if st^.csCurrentTeam.tsEditState.cedEphemeral.eesMultiline + editorOffset = if st^.csTeam(tId).tsEditState.cedEphemeral.eesMultiline then multilineHeightLimit else 0 render $ translateBy (Location (0, rowOffset)) $ diff --git a/src/Matterhorn/Draw/ChannelList.hs b/src/Matterhorn/Draw/ChannelList.hs --- a/src/Matterhorn/Draw/ChannelList.hs +++ b/src/Matterhorn/Draw/ChannelList.hs @@ -25,6 +25,7 @@ import Brick.Widgets.Border import Brick.Widgets.Center (hCenter) import qualified Data.Text as T +import Data.Maybe ( fromJust ) import Lens.Micro.Platform (non) import qualified Network.Mattermost.Types as MM @@ -51,8 +52,14 @@ , entryUserStatus :: Maybe UserStatus } -renderChannelListHeader :: ChatState -> Widget Name -renderChannelListHeader st = +sbRenderer :: ScrollbarRenderer n +sbRenderer = + verticalScrollbarRenderer { renderScrollbarHandleBefore = str "▲" + , renderScrollbarHandleAfter = str "▼" + } + +renderChannelListHeader :: ChatState -> MM.TeamId -> Widget Name +renderChannelListHeader st tId = vBox [ teamHeader , selfHeader , unreadCountHeader @@ -65,67 +72,82 @@ selfHeader = hCenter $ colorUsername myUsername_ myUsername_ (T.singleton statusSigil <> " " <> addUserSigil myUsername_) - teamNameStr = T.strip $ sanitizeUserText $ MM.teamDisplayName $ st^.csCurrentTeam.tsTeam + teamNameStr = T.strip $ sanitizeUserText $ MM.teamDisplayName $ st^.csTeam(tId).tsTeam statusSigil = maybe ' ' userSigilFromInfo me me = userById (myUserId st) st unreadCountHeader = hCenter $ txt $ "Unread: " <> (T.pack $ show unreadCount) - unreadCount = sum $ (channelListGroupUnread . fst) <$> Z.toList (st^.csCurrentTeam.tsFocus) + unreadCount = sum $ (channelListGroupUnread . fst) <$> Z.toList (st^.csTeam(tId).tsFocus) -renderChannelList :: ChatState -> Widget Name -renderChannelList st = - viewport (ChannelList tId) Vertical body +renderChannelList :: ChatState -> MM.TeamId -> Widget Name +renderChannelList st tId = + header <=> vpBody where + (sbOrientation, sbPad) = case st^.csResources.crConfiguration.configChannelListOrientationL of + ChannelListLeft -> (OnLeft, padLeft (Pad 1)) + ChannelListRight -> (OnRight, padRight (Pad 1)) myUsername_ = myUsername st - channelName e = ClickableChannelListEntry $ channelListEntryChannelId e + channelName e = ClickableChannelListEntry $ channelListEntryChannelId e renderEntry s e = clickable (channelName e) $ - renderChannelListEntry myUsername_ $ mkChannelEntryData s e - tId = st^.csCurrentTeamId - body = case st^.csCurrentTeam.tsMode of + renderChannelListEntry tId myUsername_ $ mkChannelEntryData s tId e + header = renderChannelListHeader st tId + vpBody = withVScrollBarRenderer sbRenderer $ + withVScrollBars sbOrientation $ + withVScrollBarHandles $ + withClickableVScrollBars VScrollBar $ + viewport (ChannelList tId) Vertical $ sbPad body + body = case st^.csTeam(tId).tsMode of ChannelSelect -> - let zipper = st^.csCurrentTeam.tsChannelSelectState.channelSelectMatches + let zipper = st^.csTeam(tId).tsChannelSelectState.channelSelectMatches matches = if Z.isEmpty zipper then [hCenter $ txt "No matches"] - else (renderChannelListGroup st - (renderChannelSelectListEntry (Z.focus zipper)) <$> + else (renderChannelListGroup False st + (renderChannelSelectListEntry tId (Z.focus zipper)) <$> Z.toList zipper) - in vBox $ - renderChannelListHeader st : - matches + in vBox matches _ -> cached (ChannelSidebar tId) $ vBox $ - renderChannelListHeader st : - (renderChannelListGroup st renderEntry <$> Z.toList (st^.csCurrentTeam.tsFocus)) + (renderChannelListGroup True st renderEntry <$> Z.toList (st^.csTeam(tId).tsFocus)) renderChannelListGroupHeading :: ChannelListGroup -> Widget Name renderChannelListGroupHeading g = - let label = case channelListGroupLabel g of + let label = channelListGroupLabel g + labelStr = case label of ChannelGroupPublicChannels -> "Public Channels" ChannelGroupPrivateChannels -> "Private Channels" ChannelGroupFavoriteChannels -> "Favorite Channels" ChannelGroupDirectMessages -> "Direct Messages" unread = channelListGroupUnread g + collapsed = channelListGroupCollapsed g addUnread = if unread > 0 then (<+> (withDefAttr unreadGroupMarkerAttr $ txt "*")) else id - labelWidget = addUnread $ withDefAttr channelListHeaderAttr $ txt label - in hBorderWithLabel labelWidget + addExpand = if collapsed + then (<+> (withDefAttr unreadGroupMarkerAttr $ txt "[+]")) + else id + labelWidget = addExpand $ addUnread $ withDefAttr channelListHeaderAttr $ txt labelStr + in hBorderWithLabel $ clickable (ClickableChannelListGroupHeading label) labelWidget -renderChannelListGroup :: ChatState +renderChannelListGroup :: Bool + -- ^ Whether to draw empty groups (just show + -- their headings) + -> ChatState -> (ChatState -> e -> Widget Name) -> (ChannelListGroup, [e]) -> Widget Name -renderChannelListGroup st renderEntry (group, es) = +renderChannelListGroup False _ _ (_, []) = emptyWidget +renderChannelListGroup _ st renderEntry (group, es) = let heading = renderChannelListGroupHeading group entryWidgets = renderEntry st <$> es - in if null entryWidgets - then emptyWidget - else vBox (heading : entryWidgets) + in if channelListGroupEntries group > 0 || (channelListGroupCollapsed group) + then vBox (heading : entryWidgets) + else emptyWidget mkChannelEntryData :: ChatState + -> MM.TeamId -> ChannelListEntry -> ChannelListEntryData -mkChannelEntryData st e = +mkChannelEntryData st tId e = ChannelListEntryData { entrySigil = sigilWithSpace , entryLabel = name , entryHasUnread = unread @@ -139,10 +161,10 @@ where cId = channelListEntryChannelId e unread = channelListEntryUnread e - Just chan = findChannelById cId (st^.csChannels) - recent = isRecentChannel st cId - ret = isReturnChannel st cId - current = isCurrentChannel st cId + chan = fromJust $ findChannelById cId (st^.csChannels) + recent = isRecentChannel st tId cId + ret = isReturnChannel st tId cId + current = isCurrentChannel st tId cId muted = channelListEntryMuted e (name, normalSigil, addSpace, status) = case channelListEntryType e of CLChannel -> @@ -150,7 +172,7 @@ CLGroupDM -> (chan^.ccInfo.cdDisplayName, Just " ", True, Nothing) CLUserDM uId -> - let Just u = userById uId st + let u = fromJust $ userById uId st uname = if useNickname st then u^.uiNickName.non (u^.uiName) else u^.uiName @@ -170,13 +192,13 @@ -- | Render an individual Channel List entry (in Normal mode) with -- appropriate visual decorations. -renderChannelListEntry :: Text -> ChannelListEntryData -> Widget Name -renderChannelListEntry myUName entry = body +renderChannelListEntry :: MM.TeamId -> Text -> ChannelListEntryData -> Widget Name +renderChannelListEntry tId myUName entry = body where body = decorate $ decorateEntry entry $ decorateMentions entry $ padRight Max $ entryWidget $ entrySigil entry <> entryLabel entry decorate = if | entryIsCurrent entry -> - visible . forceAttr currentChannelNameAttr + reportExtent (SelectedChannelListEntry tId) . forceAttr currentChannelNameAttr | entryMentions entry > 0 && not (entryIsMuted entry) -> forceAttr mentionsChannelAttr | entryHasUnread entry -> @@ -190,16 +212,17 @@ -- | Render an individual entry when in Channel Select mode, -- highlighting the matching portion, or completely suppressing the -- entry if it doesn't match. -renderChannelSelectListEntry :: Maybe ChannelSelectMatch +renderChannelSelectListEntry :: MM.TeamId + -> Maybe ChannelSelectMatch -> ChatState -> ChannelSelectMatch -> Widget Name -renderChannelSelectListEntry curMatch st match = +renderChannelSelectListEntry tId curMatch st match = let ChannelSelectMatch preMatch inMatch postMatch _ entry = match maybeSelect = if (Just entry) == (matchEntry <$> curMatch) then visible . withDefAttr currentChannelNameAttr else id - entryData = mkChannelEntryData st entry + entryData = mkChannelEntryData st tId entry decorate = if | entryMentions entryData > 0 && not (entryIsMuted entryData) -> withDefAttr mentionsChannelAttr | entryHasUnread entryData -> diff --git a/src/Matterhorn/Draw/ChannelListOverlay.hs b/src/Matterhorn/Draw/ChannelListOverlay.hs --- a/src/Matterhorn/Draw/ChannelListOverlay.hs +++ b/src/Matterhorn/Draw/ChannelListOverlay.hs @@ -19,9 +19,9 @@ import Matterhorn.Themes -drawChannelListOverlay :: ChatState -> Widget Name -drawChannelListOverlay st = - let overlay = drawListOverlay (st^.csCurrentTeam.tsChannelListOverlay) channelSearchScopeHeader +drawChannelListOverlay :: ChatState -> TeamId -> Widget Name +drawChannelListOverlay st tId = + let overlay = drawListOverlay (st^.csTeam(tId).tsChannelListOverlay) channelSearchScopeHeader channelSearchScopeNoResults channelSearchScopePrompt renderChannel Nothing diff --git a/src/Matterhorn/Draw/ChannelTopicWindow.hs b/src/Matterhorn/Draw/ChannelTopicWindow.hs --- a/src/Matterhorn/Draw/ChannelTopicWindow.hs +++ b/src/Matterhorn/Draw/ChannelTopicWindow.hs @@ -16,14 +16,16 @@ import qualified Data.Text as T import Data.Text.Zipper ( insertChar, gotoEOL ) +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types import Matterhorn.Draw.Buttons import Matterhorn.Draw.RichText import Matterhorn.Themes -drawChannelTopicWindow :: ChatState -> Widget Name -drawChannelTopicWindow st = +drawChannelTopicWindow :: ChatState -> TeamId -> Widget Name +drawChannelTopicWindow st tId = centerLayer $ hLimit maxWindowWidth $ joinBorders $ @@ -44,13 +46,12 @@ ] where baseUrl = serverBaseUrl st tId - tId = st^.csCurrentTeamId editorHeight = 5 previewHeight = 5 maxWindowWidth = 70 - foc = st^.csCurrentTeam.tsChannelTopicDialog.channelTopicDialogFocus - ed = st^.csCurrentTeam.tsChannelTopicDialog.channelTopicDialogEditor - hSet = getHighlightSet st + foc = st^.csTeam(tId).tsChannelTopicDialog.channelTopicDialogFocus + ed = st^.csTeam(tId).tsChannelTopicDialog.channelTopicDialogEditor + hSet = getHighlightSet st tId topicTxtWithCursor = T.unlines $ getEditContents $ applyEdit (gotoEOL >>> insertChar cursorSentinel) ed diff --git a/src/Matterhorn/Draw/DeleteChannelConfirm.hs b/src/Matterhorn/Draw/DeleteChannelConfirm.hs --- a/src/Matterhorn/Draw/DeleteChannelConfirm.hs +++ b/src/Matterhorn/Draw/DeleteChannelConfirm.hs @@ -7,6 +7,8 @@ import Prelude () import Matterhorn.Prelude +import Network.Mattermost.Types ( TeamId ) + import Brick import Brick.Widgets.Border import Brick.Widgets.Center @@ -15,14 +17,20 @@ import Matterhorn.Types -drawDeleteChannelConfirm :: ChatState -> Widget Name -drawDeleteChannelConfirm st = - let cName = st^.csCurrentChannel.ccInfo.cdName - in centerLayer $ hLimit 50 $ vLimit 15 $ - withDefAttr dialogAttr $ - borderWithLabel (txt "Confirm Delete Channel") $ - vBox [ padBottom (Pad 1) $ hCenter $ txt "Are you sure you want to delete this channel?" - , padBottom (Pad 1) $ hCenter $ withDefAttr dialogEmphAttr $ txt cName - , hCenter $ txt "Press " <+> (withDefAttr dialogEmphAttr $ txt "Y") <+> txt " to delete the channel" - , hCenter $ txt "or any other key to cancel." - ] +drawDeleteChannelConfirm :: ChatState -> TeamId -> Widget Name +drawDeleteChannelConfirm st tId = + case st^.csCurrentChannelId(tId) of + Nothing -> emptyWidget + Just cId -> + case st^?csChannel(cId) of + Nothing -> emptyWidget + Just chan -> + let cName = chan^.ccInfo.cdName + in centerLayer $ hLimit 50 $ vLimit 15 $ + withDefAttr dialogAttr $ + borderWithLabel (txt "Confirm Delete Channel") $ + vBox [ padBottom (Pad 1) $ hCenter $ txt "Are you sure you want to delete this channel?" + , padBottom (Pad 1) $ hCenter $ withDefAttr dialogEmphAttr $ txt cName + , hCenter $ txt "Press " <+> (withDefAttr dialogEmphAttr $ txt "Y") <+> txt " to delete the channel" + , hCenter $ txt "or any other key to cancel." + ] diff --git a/src/Matterhorn/Draw/LeaveChannelConfirm.hs b/src/Matterhorn/Draw/LeaveChannelConfirm.hs --- a/src/Matterhorn/Draw/LeaveChannelConfirm.hs +++ b/src/Matterhorn/Draw/LeaveChannelConfirm.hs @@ -7,6 +7,8 @@ import Prelude () import Matterhorn.Prelude +import Network.Mattermost.Types ( TeamId ) + import Brick import Brick.Widgets.Border import Brick.Widgets.Center @@ -15,14 +17,20 @@ import Matterhorn.Types -drawLeaveChannelConfirm :: ChatState -> Widget Name -drawLeaveChannelConfirm st = - let cName = st^.csCurrentChannel.ccInfo.cdName - in centerLayer $ hLimit 50 $ vLimit 15 $ - withDefAttr dialogAttr $ - borderWithLabel (txt "Confirm Leave Channel") $ - vBox [ padBottom (Pad 1) $ hCenter $ txt "Are you sure you want to leave this channel?" - , padBottom (Pad 1) $ hCenter $ withDefAttr dialogEmphAttr $ txt cName - , hCenter $ txt "Press " <+> (withDefAttr dialogEmphAttr $ txt "Y") <+> txt " to leave the channel" - , hCenter $ txt "or any other key to cancel." - ] +drawLeaveChannelConfirm :: ChatState -> TeamId -> Widget Name +drawLeaveChannelConfirm st tId = + case st^.csCurrentChannelId(tId) of + Nothing -> emptyWidget + Just cId -> + case st^?csChannel(cId) of + Nothing -> emptyWidget + Just chan -> + let cName = chan^.ccInfo.cdName + in centerLayer $ hLimit 50 $ vLimit 15 $ + withDefAttr dialogAttr $ + borderWithLabel (txt "Confirm Leave Channel") $ + vBox [ padBottom (Pad 1) $ hCenter $ txt "Are you sure you want to leave this channel?" + , padBottom (Pad 1) $ hCenter $ withDefAttr dialogEmphAttr $ txt cName + , hCenter $ txt "Press " <+> (withDefAttr dialogEmphAttr $ txt "Y") <+> txt " to leave the channel" + , hCenter $ txt "or any other key to cancel." + ] diff --git a/src/Matterhorn/Draw/Main.hs b/src/Matterhorn/Draw/Main.hs --- a/src/Matterhorn/Draw/Main.hs +++ b/src/Matterhorn/Draw/Main.hs @@ -14,6 +14,7 @@ import Data.Char ( isSpace, isPunctuation ) import qualified Data.Foldable as F import Data.List ( intersperse ) +import Data.Maybe ( fromJust ) import qualified Data.Map as M import qualified Data.Sequence as Seq import qualified Data.Set as S @@ -46,7 +47,7 @@ import Matterhorn.Types import Matterhorn.Types.Common ( sanitizeUserText ) import Matterhorn.Types.DirectionalSeq ( emptyDirSeq ) -import Matterhorn.Types.RichText ( parseMarkdown, TeamBaseURL, Inline(EHyperlink, EUser) ) +import Matterhorn.Types.RichText ( parseMarkdown, TeamBaseURL ) import Matterhorn.Types.KeyEvents import qualified Matterhorn.Zipper as Z @@ -96,17 +97,17 @@ -- misspelling list. deriving (Show) -drawEditorContents :: ChatState -> HighlightSet -> [Text] -> Widget Name -drawEditorContents st hs = +drawEditorContents :: ChatState -> TeamId -> HighlightSet -> [Text] -> Widget Name +drawEditorContents st tId hs = let noHighlight = txt . T.unlines - in case st^.csCurrentTeam.tsEditState.cedSpellChecker of + in case st^.csTeam(tId).tsEditState.cedSpellChecker of Nothing -> noHighlight Just _ -> - case S.null (st^.csCurrentTeam.tsEditState.cedMisspellings) of + case S.null (st^.csTeam(tId).tsEditState.cedMisspellings) of True -> noHighlight False -> doHighlightMisspellings hs - (st^.csCurrentTeam.tsEditState.cedMisspellings) + (st^.csTeam(tId).tsEditState.cedMisspellings) -- | This function takes a set of misspellings from the spell -- checker, the editor lines, and builds a rendering of the text with @@ -228,27 +229,26 @@ in vBox $ handleLine <$> contents -renderUserCommandBox :: ChatState -> HighlightSet -> Widget Name -renderUserCommandBox st hs = - let prompt = txt $ case st^.csCurrentTeam.tsEditState.cedEditMode of +renderUserCommandBox :: ChatState -> TeamId -> HighlightSet -> Widget Name +renderUserCommandBox st tId hs = + let prompt = txt $ case st^.csTeam(tId).tsEditState.cedEditMode of Replying _ _ -> "reply> " Editing _ _ -> "edit> " NewPost -> "> " - tId = st^.csCurrentTeamId - inputBox = renderEditor (drawEditorContents st hs) True (st^.csCurrentTeam.tsEditState.cedEditor) - curContents = getEditContents $ st^.csCurrentTeam.tsEditState.cedEditor + inputBox = renderEditor (drawEditorContents st tId hs) True (st^.csTeam(tId).tsEditState.cedEditor) + curContents = getEditContents $ st^.csTeam(tId).tsEditState.cedEditor multilineContent = length curContents > 1 multilineHints = hBox [ borderElem bsHorizontal , str $ "[" <> (show $ (+1) $ fst $ cursorPosition $ - st^.csCurrentTeam.tsEditState.cedEditor.editContentsL) <> + st^.csTeam(tId).tsEditState.cedEditor.editContentsL) <> "/" <> (show $ length curContents) <> "]" , hBorderWithLabel $ withDefAttr clientEmphAttr $ txt $ "In multi-line mode. Press " <> multiLineToggleKey <> " to finish." ] - replyDisplay = case st^.csCurrentTeam.tsEditState.cedEditMode of + replyDisplay = case st^.csTeam(tId).tsEditState.cedEditMode of Replying msg _ -> let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply in hBox [ replyArrow @@ -276,7 +276,7 @@ kc = st^.csResources.crConfiguration.configUserKeysL multiLineToggleKey = ppBinding $ firstActiveBinding kc ToggleMultiLineEvent - commandBox = case st^.csCurrentTeam.tsEditState.cedEphemeral.eesMultiline of + commandBox = case st^.csTeam(tId).tsEditState.cedEphemeral.eesMultiline of False -> let linesStr = "line" <> if numLines == 1 then "" else "s" numLines = length curContents @@ -293,8 +293,10 @@ True -> vLimit multilineHeightLimit inputBox <=> multilineHints in replyDisplay <=> commandBox -renderChannelHeader :: ChatState -> HighlightSet -> ClientChannel -> Widget Name -renderChannelHeader st hs chan = +renderChannelHeader :: ChatState -> TeamId -> HighlightSet -> Maybe ClientChannel -> Widget Name +renderChannelHeader _ _ _ Nothing = + txt " " +renderChannelHeader st tId hs (Just chan) = let chnType = chan^.ccInfo.cdType topicStr = chan^.ccInfo.cdHeader userHeader u = let s = T.intercalate " " $ filter (not . T.null) parts @@ -336,18 +338,14 @@ channelNamePair channelNamePair = chanName <> " - " <> (chan^.ccInfo.cdDisplayName) chanName = mkChannelName st (chan^.ccInfo) - tId = st^.csCurrentTeamId baseUrl = serverBaseUrl st tId - clickableInlines i (EHyperlink u _) = Just $ ClickableURL ChannelTopic i $ LinkURL u - clickableInlines i (EUser n) = Just $ ClickableUsername ChannelTopic i n - clickableInlines _ _ = Nothing in renderText' (Just baseUrl) (myUsername st) - hs (Just clickableInlines) + hs (Just (mkClickableInline Nothing (Just $ ChannelTopic $ chan^.ccInfo.cdChannelId))) (channelNameString <> maybeTopic) -renderCurrentChannelDisplay :: ChatState -> HighlightSet -> Widget Name -renderCurrentChannelDisplay st hs = header <=> hBorder <=> messages +renderCurrentChannelDisplay :: ChatState -> TeamId -> HighlightSet -> Widget Name +renderCurrentChannelDisplay st tId hs = header <=> hBorder <=> messages where header = if st^.csResources.crConfiguration.configShowChannelListL @@ -367,7 +365,7 @@ ctx <- getContext statusBox <- render $ hLimit (configChannelListWidth $ st^.csResources.crConfiguration) $ - (renderChannelListHeader st) + (renderChannelListHeader st tId) let channelHeaderWidth = ctx^.availWidthL - (Vty.imageWidth $ statusBox^.imageL) - 1 @@ -380,7 +378,7 @@ headerWidget = resultToWidget channelHeaderResult borderWidget = vLimit maxHeight vBorder - render $ if st^.csCurrentTeam.tsMode == ChannelSelect + render $ if st^.csTeam(tId).tsMode == ChannelSelect then headerWidget else hBox $ case st^.csChannelListOrientation of ChannelListLeft -> @@ -394,28 +392,36 @@ , statusBoxWidget ] + mcId = st^.(csCurrentChannelId tId) + mChan = maybe Nothing (\cId -> st^?csChannel(cId)) mcId + channelHeader = withDefAttr channelHeaderAttr $ padRight Max $ - renderChannelHeader st hs chan + renderChannelHeader st tId hs mChan messages = padTop Max chatText - chatText = case st^.csCurrentTeam.tsMode of - MessageSelect -> - freezeBorders $ - renderMessagesWithSelect (st^.csCurrentTeam.tsMessageSelect) channelMessages - MessageSelectDeleteConfirm -> - freezeBorders $ - renderMessagesWithSelect (st^.csCurrentTeam.tsMessageSelect) channelMessages - _ -> - cached (ChannelMessages cId) $ - freezeBorders $ - renderLastMessages st hs editCutoff $ - retrogradeMsgsWithThreadStates $ - reverseMessages channelMessages + chatText = + case mcId of + Nothing -> fill ' ' + Just cId -> + case st^.csTeam(tId).tsMode of + MessageSelect -> + freezeBorders $ + renderMessagesWithSelect cId (st^.csTeam(tId).tsMessageSelect) (channelMessages cId) + MessageSelectDeleteConfirm -> + freezeBorders $ + renderMessagesWithSelect cId (st^.csTeam(tId).tsMessageSelect) (channelMessages cId) + _ -> + cached (ChannelMessages cId) $ + freezeBorders $ + renderLastMessages st hs (getEditedMessageCutoff cId st) $ + retrogradeMsgsWithThreadStates $ + reverseMessages $ + channelMessages cId - renderMessagesWithSelect (MessageSelectState selMsgId) msgs = + renderMessagesWithSelect cId (MessageSelectState selMsgId) msgs = -- In this case, we want to fill the message list with messages -- but use the post ID as a cursor. To do this efficiently we -- only want to render enough messages to fill the screen. @@ -433,27 +439,22 @@ msgsWithStates = chronologicalMsgsWithThreadStates msgs in case s of Nothing -> - renderLastMessages st hs editCutoff before + renderLastMessages st hs (getEditedMessageCutoff cId st) before Just m -> unsafeRenderMessageSelection (m, (before, after)) (renderSingleMessage st hs Nothing) - cutoff = getNewMessageCutoff cId st - editCutoff = getEditedMessageCutoff cId st - messageListing = getMessageListing cId st - channelMessages = + channelMessages cId = -- If the channel is empty, add an informative message to the -- message listing to make it explicit that this channel does -- not yet have any messages. - if F.null messageListing - then addMessage (emptyChannelFillerMessage st cId) emptyDirSeq - else insertTransitions messageListing - cutoff - (getDateFormat st) - (st ^. timeZone) - - tId = st^.csCurrentTeamId - cId = st^.(csCurrentChannelId tId) - chan = st^.csCurrentChannel + let cutoff = getNewMessageCutoff cId st + messageListing = getMessageListing cId st + in if F.null messageListing + then addMessage (emptyChannelFillerMessage st cId) emptyDirSeq + else insertTransitions messageListing + cutoff + (getDateFormat st) + (st ^. timeZone) -- | Construct a single message to be displayed in the specified channel -- when it does not yet have any user messages posted to it. @@ -467,7 +468,7 @@ -- otherwise include this bogus date) or other messages (which -- would make for a broken message sorting). ts = ServerTime $ UTCTime (toEnum 0) 0 - Just chan = findChannelById cId (st^.csChannels) + chan = fromJust $ findChannelById cId (st^.csChannels) chanName = mkChannelName st (chan^.ccInfo) msg = case chan^.ccInfo.cdType of Direct -> @@ -507,9 +508,9 @@ newMessagesMsg d = newMessageOfType (T.pack "New Messages") (C NewMessagesTransition) d -renderChannelSelectPrompt :: ChatState -> Widget Name -renderChannelSelectPrompt st = - let e = st^.csCurrentTeam.tsChannelSelectState.channelSelectInput +renderChannelSelectPrompt :: ChatState -> TeamId -> Widget Name +renderChannelSelectPrompt st tId = + let e = st^.csTeam(tId).tsChannelSelectState.channelSelectInput in withDefAttr channelSelectPromptAttr $ (txt "Switch to channel [use ^ and $ to anchor]: ") <+> (renderEditor (txt . T.concat) True e) @@ -517,17 +518,18 @@ drawMain :: Bool -> ChatState -> [Widget Name] drawMain useColor st = let maybeColor = if useColor then id else forceAttr "invalid" + mtId = st^.csCurrentTeamId in maybeColor <$> [ connectionLayer st - , autocompleteLayer st - , joinBorders $ mainInterface st + , maybe emptyWidget (autocompleteLayer st) mtId + , joinBorders $ mainInterface st mtId ] teamList :: ChatState -> Widget Name teamList st = let curTid = st^.csCurrentTeamId z = st^.csTeamZipper - Just pos = Z.position z + pos = fromJust $ Z.position z teams = (\tId -> st^.csTeam(tId)) <$> (concat $ snd <$> Z.toList z) numTeams = length teams entries = mkEntry <$> teams @@ -536,7 +538,7 @@ unread = uCount > 0 uCount = unreadCount tId tName = ClickableTeamListEntry tId - in (if tId == curTid + in (if Just tId == curTid then visible . withDefAttr currentTeamAttr else if unread then withDefAttr unreadChannelAttr @@ -569,9 +571,9 @@ withDefAttr errorMessageAttr $ border $ str msg -urlSelectBottomBar :: ChatState -> Widget Name -urlSelectBottomBar st = - case listSelectedElement $ st^.csCurrentTeam.tsUrlList of +urlSelectBottomBar :: ChatState -> TeamId -> Widget Name +urlSelectBottomBar st tId = + case listSelectedElement $ st^.csTeam(tId).tsUrlList of Nothing -> hBorder Just (_, (_, link)) -> let options = [ ( isFile @@ -579,7 +581,7 @@ , "save attachment" ) ] - ev = keyEventBindings st urlSelectKeybindings + ev = keyEventBindings st (urlSelectKeybindings tId) isFile entry = case entry^.linkTarget of LinkFileId {} -> True _ -> False @@ -599,9 +601,9 @@ , hBorder ] -messageSelectBottomBar :: ChatState -> Widget Name -messageSelectBottomBar st = - case getSelectedMessage st of +messageSelectBottomBar :: ChatState -> TeamId -> Widget Name +messageSelectBottomBar st tId = + case getSelectedMessage tId st of Nothing -> emptyWidget Just postMsg -> let optionList = if null usableOptions @@ -617,7 +619,7 @@ hasURLs = numURLs > 0 openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s hasVerb = isJust (findVerbatimChunk (postMsg^.mText)) - ev = keyEventBindings st messageSelectKeybindings + ev = keyEventBindings st (messageSelectKeybindings tId) -- make sure these keybinding pieces are up-to-date! options = [ ( not . isGap , ev YankWholeMessageEvent @@ -679,7 +681,6 @@ in hBox [ borderElem bsHorizontal , txt "[" - , txt "Message select: " , optionList , txt "]" , hBorder @@ -719,12 +720,11 @@ render $ vLimit previewMaxHeight $ viewport (MessagePreviewViewport tId) Vertical $ (resultToWidget result) -inputPreview :: ChatState -> HighlightSet -> Widget Name -inputPreview st hs | not $ st^.csResources.crConfiguration.configShowMessagePreviewL = emptyWidget - | otherwise = thePreview +inputPreview :: ChatState -> TeamId -> HighlightSet -> Widget Name +inputPreview st tId hs | not $ st^.csResources.crConfiguration.configShowMessagePreviewL = emptyWidget + | otherwise = thePreview where uId = myUserId st - tId = st^.csCurrentTeamId -- Insert a cursor sentinel into the input text just before -- rendering the preview. We use the inserted sentinel (which is -- not rendered) to get brick to ensure that the line the cursor is @@ -735,9 +735,9 @@ -- end of whatever line the user is editing, that is very unlikely -- to be a problem. curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $ - st^.csCurrentTeam.tsEditState.cedEditor.editContentsL + st^.csTeam(tId).tsEditState.cedEditor.editContentsL curStr = T.intercalate "\n" curContents - overrideTy = case st^.csCurrentTeam.tsEditState.cedEditMode of + overrideTy = case st^.csTeam(tId).tsEditState.cedEditMode of Editing _ ty -> Just ty _ -> Nothing baseUrl = serverBaseUrl st tId @@ -769,33 +769,36 @@ in (maybePreviewViewport tId msgPreview) <=> hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]") -userInputArea :: ChatState -> HighlightSet -> Widget Name -userInputArea st hs = +userInputArea :: ChatState -> TeamId -> HighlightSet -> Widget Name +userInputArea st tId hs = let urlSelectInputArea = hCenter $ hBox [ txt "Press " , withDefAttr clientEmphAttr $ txt "Enter" , txt " to open the selected URL or " , withDefAttr clientEmphAttr $ txt "Escape" , txt " to cancel." ] - in case st^.csCurrentTeam.tsMode of - ChannelSelect -> renderChannelSelectPrompt st + in case st^.csTeam(tId).tsMode of + ChannelSelect -> renderChannelSelectPrompt st tId UrlSelect -> urlSelectInputArea SaveAttachmentWindow {} -> urlSelectInputArea MessageSelectDeleteConfirm -> renderDeleteConfirm - _ -> renderUserCommandBox st hs + _ -> renderUserCommandBox st tId hs renderDeleteConfirm :: Widget Name renderDeleteConfirm = hCenter $ txt "Are you sure you want to delete the selected message? (y/n)" -mainInterface :: ChatState -> Widget Name -mainInterface st = +mainInterface :: ChatState -> Maybe TeamId -> Widget Name +mainInterface st mtId = vBox [ teamList st , body ] where - showChannelList = st^.csResources.crConfiguration.configShowChannelListL || - st^.csCurrentTeam.tsMode == ChannelSelect + showChannelList = + st^.csResources.crConfiguration.configShowChannelListL || + case mtId of + Nothing -> True + Just tId -> st^.csTeam(tId).tsMode == ChannelSelect body = if showChannelList then case st^.csChannelListOrientation of ChannelListLeft -> @@ -803,34 +806,47 @@ ChannelListRight -> hBox [mainDisplay, vBorder, channelList] else mainDisplay - channelList = hLimit channelListWidth (renderChannelList st) - hs = getHighlightSet st + channelList = hLimit channelListWidth $ case mtId of + Nothing -> fill ' ' + Just tId -> renderChannelList st tId channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration + mainDisplay = - vBox [ channelContents - , bottomBorder - , inputPreview st hs - , userInputArea st hs - ] - channelContents = case st^.csCurrentTeam.tsMode of - UrlSelect -> renderUrlList st - SaveAttachmentWindow {} -> renderUrlList st - _ -> maybeSubdue $ renderCurrentChannelDisplay st hs + case mtId of + Nothing -> + vBox [ fill ' ' + , hBorder + , vLimit 1 $ fill ' ' + ] + Just tId -> + let hs = getHighlightSet st tId + in vBox [ channelContents tId hs + , bottomBorder tId hs + , inputPreview st tId hs + , userInputArea st tId hs + ] - bottomBorder = case st^.csCurrentTeam.tsMode of - MessageSelect -> messageSelectBottomBar st - UrlSelect -> urlSelectBottomBar st - SaveAttachmentWindow {} -> urlSelectBottomBar st - _ -> maybeSubdue $ hBox - [ showAttachmentCount - , hBorder - , showTypingUsers - , showBusy - ] + channelContents tId hs = + case st^.csTeam(tId).tsMode of + UrlSelect -> renderUrlList st tId + SaveAttachmentWindow {} -> renderUrlList st tId + _ -> maybeSubdue tId $ renderCurrentChannelDisplay st tId hs + bottomBorder tId hs = + case st^.csTeam(tId).tsMode of + MessageSelect -> messageSelectBottomBar st tId + UrlSelect -> urlSelectBottomBar st tId + SaveAttachmentWindow {} -> urlSelectBottomBar st tId + _ -> maybeSubdue tId $ hBox + [ showAttachmentCount tId + , hBorder + , showTypingUsers tId hs + , showBusy + ] + kc = st^.csResources.crConfiguration.configUserKeysL - showAttachmentCount = - let count = length $ listElements $ st^.csCurrentTeam.tsEditState.cedAttachmentList + showAttachmentCount tId = + let count = length $ listElements $ st^.csTeam(tId).tsEditState.cedAttachmentList in if count == 0 then emptyWidget else hBox [ borderElem bsHorizontal @@ -842,25 +858,32 @@ , txt " to manage)" ] - showTypingUsers = - let format = renderText' Nothing (myUsername st) hs Nothing - in case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of - [] -> emptyWidget - [uId] | Just un <- usernameForUserId uId st -> - format $ "[" <> addUserSigil un <> " is typing]" - [uId1, uId2] | Just un1 <- usernameForUserId uId1 st - , Just un2 <- usernameForUserId uId2 st -> - format $ "[" <> addUserSigil un1 <> " and " <> addUserSigil un2 <> " are typing]" - _ -> format "[several people are typing]" + showTypingUsers tId hs = + case st^.csCurrentChannelId(tId) of + Nothing -> emptyWidget + Just cId -> + case st^?csChannel(cId) of + Nothing -> emptyWidget + Just chan -> + let format = renderText' Nothing (myUsername st) hs Nothing + in case allTypingUsers (chan^.ccInfo.cdTypingUsers) of + [] -> emptyWidget + [uId] | Just un <- usernameForUserId uId st -> + format $ "[" <> addUserSigil un <> " is typing]" + [uId1, uId2] | Just un1 <- usernameForUserId uId1 st + , Just un2 <- usernameForUserId uId2 st -> + format $ "[" <> addUserSigil un1 <> " and " <> addUserSigil un2 <> " are typing]" + _ -> format "[several people are typing]" showBusy = case st^.csWorkerIsBusy of Just (Just n) -> hLimit 2 hBorder <+> txt (T.pack $ "*" <> show n) Just Nothing -> hLimit 2 hBorder <+> txt "*" Nothing -> emptyWidget - maybeSubdue = if st^.csCurrentTeam.tsMode == ChannelSelect - then forceAttr "" - else id + maybeSubdue tId = + if st^.csTeam(tId).tsMode == ChannelSelect + then forceAttr "" + else id replyArrow :: Widget a replyArrow = diff --git a/src/Matterhorn/Draw/ManageAttachments.hs b/src/Matterhorn/Draw/ManageAttachments.hs --- a/src/Matterhorn/Draw/ManageAttachments.hs +++ b/src/Matterhorn/Draw/ManageAttachments.hs @@ -13,23 +13,25 @@ import Brick.Widgets.List import Data.Maybe ( fromJust ) +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types import Matterhorn.Types.KeyEvents import Matterhorn.Events.Keybindings ( firstActiveBinding ) import Matterhorn.Themes -drawManageAttachments :: ChatState -> Widget Name -drawManageAttachments st = +drawManageAttachments :: ChatState -> TeamId -> Widget Name +drawManageAttachments st tId = topLayer where - topLayer = case st^.csCurrentTeam.tsMode of - ManageAttachments -> drawAttachmentList st - ManageAttachmentsBrowseFiles -> drawFileBrowser st + topLayer = case st^.csTeam(tId).tsMode of + ManageAttachments -> drawAttachmentList st tId + ManageAttachmentsBrowseFiles -> drawFileBrowser st tId _ -> error "BUG: drawManageAttachments called in invalid mode" -drawAttachmentList :: ChatState -> Widget Name -drawAttachmentList st = +drawAttachmentList :: ChatState -> TeamId -> Widget Name +drawAttachmentList st tId = let addBinding = ppBinding $ firstActiveBinding kc AttachmentListAddEvent delBinding = ppBinding $ firstActiveBinding kc AttachmentListDeleteEvent escBinding = ppBinding $ firstActiveBinding kc CancelEvent @@ -40,7 +42,7 @@ vLimit 15 $ joinBorders $ borderWithLabel (withDefAttr clientEmphAttr $ txt "Attachments") $ - vBox [ renderList renderAttachmentItem True (st^.csCurrentTeam.tsEditState.cedAttachmentList) + vBox [ renderList renderAttachmentItem True (st^.csTeam(tId).tsEditState.cedAttachmentList) , hBorder , hCenter $ withDefAttr clientMessageAttr $ txt $ addBinding <> ":add " <> @@ -53,8 +55,8 @@ renderAttachmentItem _ d = padRight Max $ str $ FB.fileInfoSanitizedFilename $ attachmentDataFileInfo d -drawFileBrowser :: ChatState -> Widget Name -drawFileBrowser st = +drawFileBrowser :: ChatState -> TeamId -> Widget Name +drawFileBrowser st tId = centerLayer $ hLimit 60 $ vLimit 20 $ @@ -62,4 +64,4 @@ -- invariant: cedFileBrowser is not Nothing if appMode is -- ManageAttachmentsBrowseFiles, and that is the only way to reach -- this code, ergo the fromJust. - FB.renderFileBrowser True $ fromJust (st^.csCurrentTeam.tsEditState.cedFileBrowser) + FB.renderFileBrowser True $ fromJust (st^.csTeam(tId).tsEditState.cedFileBrowser) diff --git a/src/Matterhorn/Draw/Messages.hs b/src/Matterhorn/Draw/Messages.hs --- a/src/Matterhorn/Draw/Messages.hs +++ b/src/Matterhorn/Draw/Messages.hs @@ -9,6 +9,7 @@ , unsafeRenderMessageSelection , renderLastMessages , addEllipsis + , mkClickableInline ) where @@ -25,6 +26,7 @@ , viewr) import qualified Data.Set as Set import qualified Data.Text as T +import Data.Maybe ( fromJust ) import qualified Graphics.Vty as V import Lens.Micro.Platform ( (.~), to ) import Network.Mattermost.Lenses ( postEditAtL, postCreateAtL ) @@ -263,7 +265,7 @@ renderMessageSeq remainingHeight renderFunc limitFunc ms | messagesLength ms == 0 = return [] | otherwise = do - let Just (m, threadState) = messagesHead ms + let (m, threadState) = fromJust $ messagesHead ms maybeCache = case m^.mMessageId of Nothing -> id Just i -> cached (RenderedMessage i) @@ -290,7 +292,7 @@ go :: Int -> DirectionalSeq Retrograde (Message, ThreadState) -> RenderM Name [Result Name] go _ ms | messagesLength ms == 0 = return [] go remainingHeight ms = do - let Just (m, threadState) = messagesHead ms + let (m, threadState) = fromJust $ messagesHead ms newMessagesAbove = maybe False (isBelow m) newMessageTransition result <- render $ render1 doMsgRender m threadState @@ -322,7 +324,7 @@ results <- go targetHeight msgs render $ vBox $ resultToWidget <$> reverse results -relaxHeight :: Context -> Context +relaxHeight :: Context n -> Context n relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL)) render1 :: (Message -> ThreadState -> Widget Name) @@ -453,7 +455,7 @@ , hBox [txt " ", renderRichText mdMyUsername hs ((subtract 2) <$> w) mdWrapNonhighlightedCodeBlocks mdTruncateVerbatimBlocks - (Just mkClickableNames) (Blocks bs)] + (Just (mkClickableInline (msg^.mMessageId) Nothing)) (Blocks bs)] ] else nameNextToMessage hs w nameElems bs @@ -465,20 +467,24 @@ , renderRichText mdMyUsername hs newW mdWrapNonhighlightedCodeBlocks mdTruncateVerbatimBlocks - (Just mkClickableNames) (Blocks bs) + (Just (mkClickableInline (msg^.mMessageId) Nothing)) (Blocks bs) ] isBreak i = i `elem` [ELineBreak, ESoftBreak] - mkClickableNames i (EHyperlink u _) = - case msg^.mMessageId of - Just mId -> Just $ ClickableURLInMessage mId i $ LinkURL u - Nothing -> Nothing - mkClickableNames i (EUser name) = - case msg^.mMessageId of - Just mId -> Just $ ClickableUsernameInMessage mId i name - Nothing -> Nothing - mkClickableNames _ _ = Nothing +mkClickableInline :: Maybe MessageId -> Maybe Name -> Int -> Inline -> Maybe Name +mkClickableInline mmId _ i (EHyperlink u _) = do + mId <- mmId + return $ ClickableURLInMessage mId i $ LinkURL u +mkClickableInline mmId _ i (EUser name) = do + mId <- mmId + return $ ClickableUsernameInMessage mId i name +mkClickableInline (Just mId) _ i (EPermalink teamUrlName pId _) = + return $ ClickableURLInMessage mId i $ LinkPermalink teamUrlName pId +mkClickableInline Nothing (Just scope) i (EPermalink teamUrlName pId _) = + return $ ClickableURL scope i $ LinkPermalink teamUrlName pId +mkClickableInline _ _ _ _ = + Nothing messageReactions :: MessageData -> Maybe (Widget Name) messageReactions MessageData { mdMessage = msg, .. } = diff --git a/src/Matterhorn/Draw/NotifyPrefs.hs b/src/Matterhorn/Draw/NotifyPrefs.hs --- a/src/Matterhorn/Draw/NotifyPrefs.hs +++ b/src/Matterhorn/Draw/NotifyPrefs.hs @@ -11,15 +11,18 @@ import Brick.Widgets.Center import Brick.Forms (renderForm) import Data.List (intersperse) +import Data.Maybe (fromJust) +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Draw.Util (renderKeybindingHelp) import Matterhorn.Types import Matterhorn.Types.KeyEvents import Matterhorn.Themes -drawNotifyPrefs :: ChatState -> Widget Name -drawNotifyPrefs st = - let Just form = st^.csCurrentTeam.tsNotifyPrefs +drawNotifyPrefs :: ChatState -> TeamId -> Widget Name +drawNotifyPrefs st tId = + let form = fromJust $ st^.csTeam(tId).tsNotifyPrefs label = forceAttr clientEmphAttr $ str "Notification Preferences" formKeys = withDefAttr clientEmphAttr <$> txt <$> ["Tab", "BackTab"] bindings = vBox $ hCenter <$> [ renderKeybindingHelp st "Save" [FormSubmitEvent] <+> txt " " <+> diff --git a/src/Matterhorn/Draw/PostListOverlay.hs b/src/Matterhorn/Draw/PostListOverlay.hs --- a/src/Matterhorn/Draw/PostListOverlay.hs +++ b/src/Matterhorn/Draw/PostListOverlay.hs @@ -11,7 +11,7 @@ import Brick.Widgets.Center import Control.Monad.Trans.Reader ( withReaderT ) import qualified Data.Text as T -import Lens.Micro.Platform ( (^?), (%~), to ) +import Lens.Micro.Platform ( (%~), to ) import Network.Mattermost.Lenses import Network.Mattermost.Types @@ -30,17 +30,17 @@ withReaderT (& availWidthL %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents } -drawPostListOverlay :: PostListContents -> ChatState -> Widget Name -drawPostListOverlay contents st = joinBorders $ drawPostsBox contents st +drawPostListOverlay :: PostListContents -> ChatState -> TeamId -> Widget Name +drawPostListOverlay contents st tId = joinBorders $ drawPostsBox contents st tId -- | Draw a PostListOverlay as a floating overlay on top of whatever -- is rendered beneath it -drawPostsBox :: PostListContents -> ChatState -> Widget Name -drawPostsBox contents st = +drawPostsBox :: PostListContents -> ChatState -> TeamId -> Widget Name +drawPostsBox contents st tId = centerLayer $ hLimitWithPadding 10 $ borderWithLabel contentHeader $ padRight (Pad 1) messageListContents where -- The 'window title' of the overlay - hs = getHighlightSet st + hs = getHighlightSet st tId contentHeader = withAttr channelListHeaderAttr $ txt $ case contents of PostListFlagged -> "Flagged posts" PostListPinned cId -> @@ -52,7 +52,7 @@ then ": " <> terms else " (" <> (T.pack . show . length) entries <> "): " <> terms - entries = filterMessages knownChannel $ st^.csCurrentTeam.tsPostListOverlay.postListPosts + entries = filterMessages knownChannel $ st^.csTeam(tId).tsPostListOverlay.postListPosts messages = insertDateMarkers entries (getDateFormat st) @@ -100,7 +100,7 @@ -- The full message list, rendered with the current selection renderedMessageList = let (s, (before, after)) = splitDirSeqOn matchesMessage messagesWithStates - matchesMessage (m, _) = m^.mMessageId == (MessagePostId <$> st^.csCurrentTeam.tsPostListOverlay.postListSelected) + matchesMessage (m, _) = m^.mMessageId == (MessagePostId <$> st^.csTeam(tId).tsPostListOverlay.postListSelected) messagesWithStates = (, InThreadShowParent) <$> messages in case s of Nothing -> diff --git a/src/Matterhorn/Draw/ReactionEmojiListOverlay.hs b/src/Matterhorn/Draw/ReactionEmojiListOverlay.hs --- a/src/Matterhorn/Draw/ReactionEmojiListOverlay.hs +++ b/src/Matterhorn/Draw/ReactionEmojiListOverlay.hs @@ -10,14 +10,16 @@ import Brick.Widgets.List ( listSelectedFocusedAttr ) import qualified Data.Text as T +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) ) import Matterhorn.Types import Matterhorn.Themes -drawReactionEmojiListOverlay :: ChatState -> Widget Name -drawReactionEmojiListOverlay st = - let overlay = drawListOverlay (st^.csCurrentTeam.tsReactionEmojiListOverlay) +drawReactionEmojiListOverlay :: ChatState -> TeamId -> Widget Name +drawReactionEmojiListOverlay st tId = + let overlay = drawListOverlay (st^.csTeam(tId).tsReactionEmojiListOverlay) (const $ txt "Search Emoji") (const $ txt "No matching emoji found.") (const $ txt "Search emoji:") diff --git a/src/Matterhorn/Draw/RichText.hs b/src/Matterhorn/Draw/RichText.hs --- a/src/Matterhorn/Draw/RichText.hs +++ b/src/Matterhorn/Draw/RichText.hs @@ -129,7 +129,7 @@ , drawNameGen :: Maybe (Int -> Inline -> Maybe a) } -renderBlock :: SemEq a => Block -> M (Widget a) a +renderBlock :: (Ord a, SemEq a) => Block -> M (Widget a) a renderBlock (Table aligns headings body) = do headingWs <- mapM renderInlines headings bodyWs <- forM body $ mapM renderInlines @@ -239,7 +239,7 @@ render $ padding <+> (resultToWidget renderedText) -renderInlines :: SemEq a => Inlines -> M (Widget a) a +renderInlines :: (Ord a, SemEq a) => Inlines -> M (Widget a) a renderInlines es = do w <- asks drawLineWidth hSet <- asks drawHighlightSet @@ -254,7 +254,7 @@ (doLineWrapping width <$> (F.toList $ flattenInlineSeq hSet nameGen es)) B.render (vBox ws) -renderList :: SemEq a => ListType -> ListSpacing -> Seq Blocks -> M (Widget a) a +renderList :: (Ord a, SemEq a) => ListType -> ListSpacing -> Seq Blocks -> M (Widget a) a renderList ty _spacing bs = do let is = case ty of BulletList _ -> repeat ("• ") @@ -271,10 +271,10 @@ return $ vBox results -renderWrappedLine :: Show a => Text -> WrappedLine a -> Widget a +renderWrappedLine :: (Ord a, Show a) => Text -> WrappedLine a -> Widget a renderWrappedLine curUser l = hBox $ F.toList $ renderFlattenedValue curUser <$> l -renderFlattenedValue :: Show a => Text -> FlattenedValue a -> Widget a +renderFlattenedValue :: (Ord a, Show a) => Text -> FlattenedValue a -> Widget a renderFlattenedValue curUser (NonBreaking rs) = let renderLine = hBox . F.toList . fmap (renderFlattenedValue curUser) in vBox (F.toList $ renderLine <$> F.toList rs) diff --git a/src/Matterhorn/Draw/SaveAttachmentWindow.hs b/src/Matterhorn/Draw/SaveAttachmentWindow.hs --- a/src/Matterhorn/Draw/SaveAttachmentWindow.hs +++ b/src/Matterhorn/Draw/SaveAttachmentWindow.hs @@ -14,13 +14,15 @@ import qualified Data.Text as T +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types import Matterhorn.Draw.Buttons import Matterhorn.Themes -drawSaveAttachmentWindow :: ChatState -> Widget Name -drawSaveAttachmentWindow st = +drawSaveAttachmentWindow :: ChatState -> TeamId -> Widget Name +drawSaveAttachmentWindow st tId = centerLayer $ hLimit maxWindowWidth $ joinBorders $ @@ -37,9 +39,8 @@ ] ] where - tId = st^.csCurrentTeamId editorHeight = 1 maxWindowWidth = 50 - foc = st^.csCurrentTeam.tsSaveAttachmentDialog.attachmentPathDialogFocus - ed = st^.csCurrentTeam.tsSaveAttachmentDialog.attachmentPathEditor + foc = st^.csTeam(tId).tsSaveAttachmentDialog.attachmentPathDialogFocus + ed = st^.csTeam(tId).tsSaveAttachmentDialog.attachmentPathEditor drawEditorTxt = txt . T.unlines diff --git a/src/Matterhorn/Draw/ShowHelp.hs b/src/Matterhorn/Draw/ShowHelp.hs --- a/src/Matterhorn/Draw/ShowHelp.hs +++ b/src/Matterhorn/Draw/ShowHelp.hs @@ -14,18 +14,20 @@ import Brick import Brick.Themes ( themeDescriptions ) import Brick.Widgets.Center ( hCenter ) +import Brick.Widgets.Edit ( Editor ) import Brick.Widgets.List ( listSelectedFocusedAttr ) import qualified Data.Map as M import qualified Data.Text as T import qualified Graphics.Vty as Vty -import Lens.Micro.Platform ( singular, _Just, _2 ) +import Lens.Micro.Platform ( Lens' ) +import Network.Mattermost.Types ( TeamId ) import Network.Mattermost.Version ( mmApiVersion ) import Matterhorn.Command -import Matterhorn.Events import Matterhorn.Events.ChannelSelect import Matterhorn.Events.Keybindings +import Matterhorn.Events.Global import Matterhorn.Events.Main import Matterhorn.Events.MessageSelect import Matterhorn.Events.ThemeListOverlay @@ -442,23 +444,32 @@ keybindSections :: [(Text, [KeyEventHandler])] keybindSections = [ ("Global Keybindings", globalKeyHandlers) - , ("Help Page", helpKeyHandlers) - , ("Main Interface", mainKeyHandlers) - , ("Text Editing", editingKeyHandlers (csCurrentTeam.tsEditState.cedEditor)) - , ("Channel Select Mode", channelSelectKeyHandlers) - , ("Message Select Mode", messageSelectKeyHandlers) - , ("User Listings", userListOverlayKeyHandlers) - , ("URL Select Mode", urlSelectKeyHandlers) - , ("Theme List Window", themeListOverlayKeyHandlers) - , ("Channel Search Window", channelListOverlayKeyHandlers) - , ("Message Viewer: Common", tabbedWindowKeyHandlers (csCurrentTeam.tsViewedMessage.singular _Just._2)) - , ("Message Viewer: Message tab", viewMessageKeyHandlers) - , ("Message Viewer: Reactions tab", viewMessageReactionsKeyHandlers) - , ("Attachment List", attachmentListKeyHandlers) - , ("Attachment File Browser", attachmentBrowseKeyHandlers) - , ("Flagged Messages", postListOverlayKeyHandlers) - , ("Reaction Emoji Search Window", reactionEmojiListOverlayKeyHandlers) + , ("Help Page", helpKeyHandlers teamIdThunk) + , ("Main Interface", mainKeyHandlers teamIdThunk) + , ("Text Editing", editingKeyHandlers teamIdThunk editorThunk) + , ("Channel Select Mode", channelSelectKeyHandlers teamIdThunk) + , ("Message Select Mode", messageSelectKeyHandlers teamIdThunk) + , ("User Listings", userListOverlayKeyHandlers teamIdThunk) + , ("URL Select Mode", urlSelectKeyHandlers teamIdThunk) + , ("Theme List Window", themeListOverlayKeyHandlers teamIdThunk) + , ("Channel Search Window", channelListOverlayKeyHandlers teamIdThunk) + , ("Message Viewer: Common", tabbedWindowKeyHandlers teamIdThunk tabbedWinThunk) + , ("Message Viewer: Message tab", viewMessageKeyHandlers teamIdThunk) + , ("Message Viewer: Reactions tab", viewMessageReactionsKeyHandlers teamIdThunk) + , ("Attachment List", attachmentListKeyHandlers teamIdThunk) + , ("Attachment File Browser", attachmentBrowseKeyHandlers teamIdThunk) + , ("Flagged Messages", postListOverlayKeyHandlers teamIdThunk) + , ("Reaction Emoji Search Window", reactionEmojiListOverlayKeyHandlers teamIdThunk) ] + +teamIdThunk :: TeamId +teamIdThunk = error "BUG: should not evaluate teamIdThunk" + +tabbedWinThunk :: Lens' ChatState (TabbedWindow Int) +tabbedWinThunk = error "BUG: should not evaluate tabbedWinThunk" + +editorThunk :: Lens' ChatState (Editor Text Name) +editorThunk = error "BUG: should not evaluate editorThunk" helpBox :: Name -> Widget Name -> Widget Name helpBox n helpText = diff --git a/src/Matterhorn/Draw/TabbedWindow.hs b/src/Matterhorn/Draw/TabbedWindow.hs --- a/src/Matterhorn/Draw/TabbedWindow.hs +++ b/src/Matterhorn/Draw/TabbedWindow.hs @@ -23,12 +23,12 @@ drawTabbedWindow :: (Eq a, Show a) => TabbedWindow a -> ChatState + -> TeamId -> Widget Name -drawTabbedWindow w cs = +drawTabbedWindow w cs tId = let cur = getCurrentTabbedWindowEntry w tabBody = tweRender cur (twValue w) cs title = forceAttr clientEmphAttr $ twtTitle (twTemplate w) (tweValue cur) - tId = cs^.csCurrentTeamId in centerLayer $ vLimit (twWindowHeight w) $ hLimit (twWindowWidth w) $ @@ -57,7 +57,7 @@ then withDefAttr tabSelectedAttr else withDefAttr tabUnselectedAttr isCurrent = tweValue e == tweValue cur - makeVisible = if isCurrent then visible else id + makeTabVisible = if isCurrent then visible else id decorateTab v = Widget Fixed Fixed $ do result <- render v let width = Vty.imageWidth (result^.imageL) @@ -68,7 +68,7 @@ render $ vBox [ resultToWidget result , hLimit width hBorder ] - in makeVisible $ + in makeTabVisible $ decorateTab $ useAttr $ padLeftRight 2 $ diff --git a/src/Matterhorn/Draw/ThemeListOverlay.hs b/src/Matterhorn/Draw/ThemeListOverlay.hs --- a/src/Matterhorn/Draw/ThemeListOverlay.hs +++ b/src/Matterhorn/Draw/ThemeListOverlay.hs @@ -14,6 +14,8 @@ import Brick.Widgets.Border ( hBorder ) import Brick.Widgets.Center ( hCenter ) +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) ) import Matterhorn.Themes import Matterhorn.Types @@ -21,9 +23,9 @@ import Matterhorn.Events.Keybindings -drawThemeListOverlay :: ChatState -> Widget Name -drawThemeListOverlay st = - let overlay = drawListOverlay (st^.csCurrentTeam.tsThemeListOverlay) +drawThemeListOverlay :: ChatState -> TeamId -> Widget Name +drawThemeListOverlay st tId = + let overlay = drawListOverlay (st^.csTeam(tId).tsThemeListOverlay) (const $ txt "Themes") (const $ txt "No matching themes found.") (const $ txt "Search built-in themes:") diff --git a/src/Matterhorn/Draw/URLList.hs b/src/Matterhorn/Draw/URLList.hs --- a/src/Matterhorn/Draw/URLList.hs +++ b/src/Matterhorn/Draw/URLList.hs @@ -13,7 +13,7 @@ import qualified Data.Foldable as F import Lens.Micro.Platform ( to ) -import Network.Mattermost.Types ( ServerTime(..), idString ) +import Network.Mattermost.Types ( ServerTime(..), TeamId, idString ) import Matterhorn.Draw.Messages import Matterhorn.Draw.Util @@ -23,24 +23,33 @@ import Matterhorn.Types.RichText -renderUrlList :: ChatState -> Widget Name -renderUrlList st = +renderUrlList :: ChatState -> TeamId -> Widget Name +renderUrlList st tId = + case st^.csCurrentChannelId(tId) of + Nothing -> emptyWidget + Just cId -> + case st^?csChannel(cId) of + Nothing -> emptyWidget + Just ch -> renderUrlList' st tId ch + +renderUrlList' :: ChatState -> TeamId -> ClientChannel -> Widget Name +renderUrlList' st tId chan = header <=> urlDisplay where + cName = mkChannelName st (chan^.ccInfo) header = (withDefAttr channelHeaderAttr $ vLimit 1 $ - (renderText' Nothing "" (getHighlightSet st) Nothing $ - "URLs: " <> (mkChannelName st (st^.csCurrentChannel.ccInfo))) <+> + (renderText' Nothing "" hSet Nothing $ "URLs: " <> cName) <+> fill ' ') <=> hBorder urlDisplay = if F.length urls == 0 then str "No URLs found in this channel." else renderList renderItem True urls - urls = st^.csCurrentTeam.tsUrlList + urls = st^.csTeam(tId).tsUrlList me = myUsername st - hSet = getHighlightSet st + hSet = getHighlightSet st tId renderItem sel (i, link) = let time = link^.linkTime diff --git a/src/Matterhorn/Draw/UserListOverlay.hs b/src/Matterhorn/Draw/UserListOverlay.hs --- a/src/Matterhorn/Draw/UserListOverlay.hs +++ b/src/Matterhorn/Draw/UserListOverlay.hs @@ -14,15 +14,17 @@ import qualified Data.Text as T import qualified Graphics.Vty as V +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Draw.Util ( userSigilFromInfo ) import Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) ) import Matterhorn.Themes import Matterhorn.Types -drawUserListOverlay :: ChatState -> Widget Name -drawUserListOverlay st = - let overlay = drawListOverlay (st^.csCurrentTeam.tsUserListOverlay) userSearchScopeHeader +drawUserListOverlay :: ChatState -> TeamId -> Widget Name +drawUserListOverlay st tId = + let overlay = drawListOverlay (st^.csTeam(tId).tsUserListOverlay) userSearchScopeHeader userSearchScopeNoResults userSearchScopePrompt (renderUser (myUsername st)) Nothing diff --git a/src/Matterhorn/Events.hs b/src/Matterhorn/Events.hs --- a/src/Matterhorn/Events.hs +++ b/src/Matterhorn/Events.hs @@ -1,7 +1,5 @@ module Matterhorn.Events ( onEvent - , globalKeybindings - , globalKeyHandlers ) where @@ -15,6 +13,7 @@ import Lens.Micro.Platform ( (.=), _2, singular, _Just ) import qualified System.IO.Error as IO +import qualified Network.Mattermost.Types as MM import qualified Network.Mattermost.Endpoints as MM import Network.Mattermost.Exceptions ( mattermostErrorMessage ) @@ -24,7 +23,6 @@ import Matterhorn.State.ChannelList import Matterhorn.State.Channels import Matterhorn.State.Common -import Matterhorn.State.Help import Matterhorn.State.Messages import Matterhorn.Types @@ -32,6 +30,7 @@ import Matterhorn.Events.ChannelTopicWindow import Matterhorn.Events.SaveAttachmentWindow import Matterhorn.Events.DeleteChannelConfirm +import Matterhorn.Events.Global import Matterhorn.Events.Keybindings import Matterhorn.Events.LeaveChannelConfirm import Matterhorn.Events.Main @@ -59,9 +58,11 @@ onBrickEvent (AppEvent e) = onAppEvent e onBrickEvent (VtyEvent (Vty.EvKey (Vty.KChar 'l') [Vty.MCtrl])) = do + csLastMouseDownEvent .= Nothing vty <- mh getVtyHandle liftIO $ Vty.refresh vty -onBrickEvent (VtyEvent e) = +onBrickEvent (VtyEvent e) = do + csLastMouseDownEvent .= Nothing onVtyEvent e onBrickEvent e@(MouseDown n button modifier _) = do mhLog LogGeneral $ T.pack $ "MOUSE EVENT: " <> show (n, button, modifier) @@ -73,8 +74,9 @@ when shouldHandle $ do mhLog LogGeneral "Handling mouse event" csLastMouseDownEvent .= Just e - mode <- use (csCurrentTeam.tsMode) - mouseHandlerByMode mode e + withCurrentTeam $ \tId -> do + mode <- use (csTeam(tId).tsMode) + mouseHandlerByMode tId mode e onBrickEvent (MouseUp {}) = do csLastMouseDownEvent .= Nothing mhContinueWithoutRedraw @@ -89,7 +91,7 @@ csConnectionStatus .= Connected refreshChannelsAndUsers refreshClientConfig - fetchVisibleIfNeeded + withCurrentTeam fetchVisibleIfNeeded onAppEvent (RateLimitExceeded winSz) = mhError $ GenericError $ T.pack $ let s = if winSz == 1 then "" else "s" @@ -192,7 +194,7 @@ onVtyEvent :: Vty.Event -> MH () onVtyEvent e = do case e of - (Vty.EvResize _ _) -> + (Vty.EvResize _ _) -> do -- On resize, invalidate the entire rendering cache since -- many things depend on the window size. -- @@ -201,48 +203,42 @@ -- to run when a resize occurs, so we don't want to stop -- processing here. mh invalidateCache + withCurrentTeam $ \tId -> + mh $ makeVisible $ SelectedChannelListEntry tId _ -> return () - void $ handleKeyboardEvent globalKeybindings handleGlobalEvent e + void $ handleKeyboardEvent globalKeybindings handleTeamModeEvent e -handleGlobalEvent :: Vty.Event -> MH () -handleGlobalEvent e = do - mode <- use (csCurrentTeam.tsMode) - globalHandlerByMode mode e +handleTeamModeEvent :: Vty.Event -> MH () +handleTeamModeEvent e = + withCurrentTeam $ \tId -> do + mode <- use (csTeam(tId).tsMode) + teamEventHandlerByMode tId mode e -globalHandlerByMode :: Mode -> Vty.Event -> MH () -globalHandlerByMode mode = +teamEventHandlerByMode :: MM.TeamId -> Mode -> Vty.Event -> MH () +teamEventHandlerByMode tId mode = case mode of - Main -> onEventMain - ShowHelp _ _ -> void . onEventShowHelp - ChannelSelect -> void . onEventChannelSelect - UrlSelect -> void . onEventUrlSelect - LeaveChannelConfirm -> onEventLeaveChannelConfirm - MessageSelect -> onEventMessageSelect - MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm - DeleteChannelConfirm -> onEventDeleteChannelConfirm - ThemeListOverlay -> onEventThemeListOverlay - PostListOverlay _ -> onEventPostListOverlay - UserListOverlay -> onEventUserListOverlay - ChannelListOverlay -> onEventChannelListOverlay - ReactionEmojiListOverlay -> onEventReactionEmojiListOverlay - ViewMessage -> void . handleTabbedWindowEvent - (csCurrentTeam.tsViewedMessage.singular _Just._2) - ManageAttachments -> onEventManageAttachments - ManageAttachmentsBrowseFiles -> onEventManageAttachments - EditNotifyPrefs -> void . onEventEditNotifyPrefs - ChannelTopicWindow -> onEventChannelTopicWindow - SaveAttachmentWindow _ -> onEventSaveAttachmentWindow - -globalKeybindings :: KeyConfig -> KeyHandlerMap -globalKeybindings = mkKeybindings globalKeyHandlers - -globalKeyHandlers :: [KeyEventHandler] -globalKeyHandlers = - [ mkKb ShowHelpEvent - "Show this help screen" - (showHelpScreen mainHelpTopic) - ] + Main -> onEventMain tId + ShowHelp _ _ -> void . onEventShowHelp tId + ChannelSelect -> void . onEventChannelSelect tId + UrlSelect -> void . onEventUrlSelect tId + LeaveChannelConfirm -> onEventLeaveChannelConfirm tId + MessageSelect -> onEventMessageSelect tId + MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm tId + DeleteChannelConfirm -> onEventDeleteChannelConfirm tId + ThemeListOverlay -> onEventThemeListOverlay tId + PostListOverlay _ -> onEventPostListOverlay tId + UserListOverlay -> onEventUserListOverlay tId + ChannelListOverlay -> onEventChannelListOverlay tId + ReactionEmojiListOverlay -> onEventReactionEmojiListOverlay tId + ViewMessage -> void . (handleTabbedWindowEvent + (csTeam(tId).tsViewedMessage.singular _Just._2) + tId) + ManageAttachments -> onEventManageAttachments tId + ManageAttachmentsBrowseFiles -> onEventManageAttachments tId + EditNotifyPrefs -> void . onEventEditNotifyPrefs tId + ChannelTopicWindow -> onEventChannelTopicWindow tId + SaveAttachmentWindow _ -> onEventSaveAttachmentWindow tId -- | Refresh client-accessible server configuration information. This -- is usually triggered when a reconnect event for the WebSocket to the diff --git a/src/Matterhorn/Events/ChannelListOverlay.hs b/src/Matterhorn/Events/ChannelListOverlay.hs --- a/src/Matterhorn/Events/ChannelListOverlay.hs +++ b/src/Matterhorn/Events/ChannelListOverlay.hs @@ -10,26 +10,28 @@ import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Events.Keybindings import Matterhorn.State.ChannelListOverlay import Matterhorn.State.ListOverlay import Matterhorn.Types -onEventChannelListOverlay :: Vty.Event -> MH () -onEventChannelListOverlay = - void . onEventListOverlay (csCurrentTeam.tsChannelListOverlay) channelListOverlayKeybindings +onEventChannelListOverlay :: TeamId -> Vty.Event -> MH () +onEventChannelListOverlay tId = + void . onEventListOverlay tId (csTeam(tId).tsChannelListOverlay) (channelListOverlayKeybindings tId) -- | The keybindings we want to use while viewing a channel list overlay -channelListOverlayKeybindings :: KeyConfig -> KeyHandlerMap -channelListOverlayKeybindings = mkKeybindings channelListOverlayKeyHandlers +channelListOverlayKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +channelListOverlayKeybindings tId = mkKeybindings (channelListOverlayKeyHandlers tId) -channelListOverlayKeyHandlers :: [KeyEventHandler] -channelListOverlayKeyHandlers = - [ mkKb CancelEvent "Close the channel search list" (exitListOverlay (csCurrentTeam.tsChannelListOverlay)) - , mkKb SearchSelectUpEvent "Select the previous channel" channelListSelectUp - , mkKb SearchSelectDownEvent "Select the next channel" channelListSelectDown - , mkKb PageDownEvent "Page down in the channel list" channelListPageDown - , mkKb PageUpEvent "Page up in the channel list" channelListPageUp - , mkKb ActivateListItemEvent "Join the selected channel" (listOverlayActivateCurrent (csCurrentTeam.tsChannelListOverlay)) +channelListOverlayKeyHandlers :: TeamId -> [KeyEventHandler] +channelListOverlayKeyHandlers tId = + [ mkKb CancelEvent "Close the channel search list" (exitListOverlay tId (csTeam(tId).tsChannelListOverlay)) + , mkKb SearchSelectUpEvent "Select the previous channel" $ channelListSelectUp tId + , mkKb SearchSelectDownEvent "Select the next channel" $ channelListSelectDown tId + , mkKb PageDownEvent "Page down in the channel list" $ channelListPageDown tId + , mkKb PageUpEvent "Page up in the channel list" $ channelListPageUp tId + , mkKb ActivateListItemEvent "Join the selected channel" (listOverlayActivateCurrent tId (csTeam(tId).tsChannelListOverlay)) ] diff --git a/src/Matterhorn/Events/ChannelSelect.hs b/src/Matterhorn/Events/ChannelSelect.hs --- a/src/Matterhorn/Events/ChannelSelect.hs +++ b/src/Matterhorn/Events/ChannelSelect.hs @@ -6,6 +6,8 @@ import Brick.Widgets.Edit ( handleEditorEvent ) import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Events.Keybindings import Matterhorn.State.Channels import Matterhorn.State.ChannelSelect @@ -14,32 +16,32 @@ import qualified Matterhorn.Zipper as Z -onEventChannelSelect :: Vty.Event -> MH Bool -onEventChannelSelect = - handleKeyboardEvent channelSelectKeybindings $ \e -> do - handled <- handleKeyboardEvent (editingKeybindings (csCurrentTeam.tsChannelSelectState.channelSelectInput)) (const $ return ()) e +onEventChannelSelect :: TeamId -> Vty.Event -> MH Bool +onEventChannelSelect tId = + handleKeyboardEvent (channelSelectKeybindings tId) $ \e -> do + handled <- handleKeyboardEvent (editingKeybindings tId (csTeam(tId).tsChannelSelectState.channelSelectInput)) (const $ return ()) e when (not handled) $ - mhHandleEventLensed (csCurrentTeam.tsChannelSelectState.channelSelectInput) handleEditorEvent e + mhHandleEventLensed (csTeam(tId).tsChannelSelectState.channelSelectInput) handleEditorEvent e - updateChannelSelectMatches + updateChannelSelectMatches tId -channelSelectKeybindings :: KeyConfig -> KeyHandlerMap -channelSelectKeybindings = mkKeybindings channelSelectKeyHandlers +channelSelectKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +channelSelectKeybindings tId = mkKeybindings (channelSelectKeyHandlers tId) -channelSelectKeyHandlers :: [KeyEventHandler] -channelSelectKeyHandlers = +channelSelectKeyHandlers :: TeamId -> [KeyEventHandler] +channelSelectKeyHandlers tId = [ staticKb "Switch to selected channel" (Vty.EvKey Vty.KEnter []) $ do - matches <- use (csCurrentTeam.tsChannelSelectState.channelSelectMatches) + matches <- use (csTeam(tId).tsChannelSelectState.channelSelectMatches) case Z.focus matches of Nothing -> return () Just match -> do - setMode Main - setFocus $ channelListEntryChannelId $ matchEntry match + setMode tId Main + setFocus tId $ channelListEntryChannelId $ matchEntry match - , mkKb CancelEvent "Cancel channel selection" $ setMode Main - , mkKb NextChannelEvent "Select next match" channelSelectNext - , mkKb PrevChannelEvent "Select previous match" channelSelectPrevious - , mkKb NextChannelEventAlternate "Select next match (alternate binding)" channelSelectNext - , mkKb PrevChannelEventAlternate "Select previous match (alternate binding)" channelSelectPrevious + , mkKb CancelEvent "Cancel channel selection" $ setMode tId Main + , mkKb NextChannelEvent "Select next match" $ channelSelectNext tId + , mkKb PrevChannelEvent "Select previous match" $ channelSelectPrevious tId + , mkKb NextChannelEventAlternate "Select next match (alternate binding)" $ channelSelectNext tId + , mkKb PrevChannelEventAlternate "Select previous match (alternate binding)" $ channelSelectPrevious tId ] diff --git a/src/Matterhorn/Events/ChannelTopicWindow.hs b/src/Matterhorn/Events/ChannelTopicWindow.hs --- a/src/Matterhorn/Events/ChannelTopicWindow.hs +++ b/src/Matterhorn/Events/ChannelTopicWindow.hs @@ -12,37 +12,39 @@ import Lens.Micro.Platform ( (%=) ) import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types import Matterhorn.State.Channels ( setChannelTopic ) -onEventChannelTopicWindow :: Vty.Event -> MH () -onEventChannelTopicWindow (Vty.EvKey (Vty.KChar '\t') []) = - csCurrentTeam.tsChannelTopicDialog.channelTopicDialogFocus %= focusNext -onEventChannelTopicWindow (Vty.EvKey Vty.KBackTab []) = - csCurrentTeam.tsChannelTopicDialog.channelTopicDialogFocus %= focusPrev -onEventChannelTopicWindow e@(Vty.EvKey Vty.KEnter []) = do - f <- use (csCurrentTeam.tsChannelTopicDialog.channelTopicDialogFocus) +onEventChannelTopicWindow :: TeamId -> Vty.Event -> MH () +onEventChannelTopicWindow tId (Vty.EvKey (Vty.KChar '\t') []) = + csTeam(tId).tsChannelTopicDialog.channelTopicDialogFocus %= focusNext +onEventChannelTopicWindow tId (Vty.EvKey Vty.KBackTab []) = + csTeam(tId).tsChannelTopicDialog.channelTopicDialogFocus %= focusPrev +onEventChannelTopicWindow tId e@(Vty.EvKey Vty.KEnter []) = do + f <- use (csTeam(tId).tsChannelTopicDialog.channelTopicDialogFocus) case focusGetCurrent f of Just (ChannelTopicSaveButton {}) -> do - ed <- use (csCurrentTeam.tsChannelTopicDialog.channelTopicDialogEditor) + ed <- use (csTeam(tId).tsChannelTopicDialog.channelTopicDialogEditor) let topic = T.unlines $ getEditContents ed - setChannelTopic topic - setMode Main + setChannelTopic tId topic + setMode tId Main Just (ChannelTopicEditor {}) -> - mhHandleEventLensed (csCurrentTeam.tsChannelTopicDialog.channelTopicDialogEditor) + mhHandleEventLensed (csTeam(tId).tsChannelTopicDialog.channelTopicDialogEditor) handleEditorEvent e Just (ChannelTopicCancelButton {}) -> - setMode Main + setMode tId Main _ -> - setMode Main -onEventChannelTopicWindow (Vty.EvKey Vty.KEsc []) = do - setMode Main -onEventChannelTopicWindow e = do - f <- use (csCurrentTeam.tsChannelTopicDialog.channelTopicDialogFocus) + setMode tId Main +onEventChannelTopicWindow tId (Vty.EvKey Vty.KEsc []) = do + setMode tId Main +onEventChannelTopicWindow tId e = do + f <- use (csTeam(tId).tsChannelTopicDialog.channelTopicDialogFocus) case focusGetCurrent f of Just (ChannelTopicEditor {}) -> - mhHandleEventLensed (csCurrentTeam.tsChannelTopicDialog.channelTopicDialogEditor) + mhHandleEventLensed (csTeam(tId).tsChannelTopicDialog.channelTopicDialogEditor) handleEditorEvent e _ -> return () diff --git a/src/Matterhorn/Events/DeleteChannelConfirm.hs b/src/Matterhorn/Events/DeleteChannelConfirm.hs --- a/src/Matterhorn/Events/DeleteChannelConfirm.hs +++ b/src/Matterhorn/Events/DeleteChannelConfirm.hs @@ -5,16 +5,18 @@ import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types import Matterhorn.State.Channels -onEventDeleteChannelConfirm :: Vty.Event -> MH () -onEventDeleteChannelConfirm (Vty.EvKey k []) = do +onEventDeleteChannelConfirm :: TeamId -> Vty.Event -> MH () +onEventDeleteChannelConfirm tId (Vty.EvKey k []) = do case k of Vty.KChar c | c `elem` ("yY"::String) -> - deleteCurrentChannel + deleteCurrentChannel tId _ -> return () - setMode Main -onEventDeleteChannelConfirm _ = do - setMode Main + setMode tId Main +onEventDeleteChannelConfirm tId _ = do + setMode tId Main diff --git a/src/Matterhorn/Events/EditNotifyPrefs.hs b/src/Matterhorn/Events/EditNotifyPrefs.hs --- a/src/Matterhorn/Events/EditNotifyPrefs.hs +++ b/src/Matterhorn/Events/EditNotifyPrefs.hs @@ -14,6 +14,7 @@ import Data.Maybe (fromJust) import qualified Graphics.Vty as V import qualified Network.Mattermost.Endpoints as MM +import Network.Mattermost.Types ( TeamId ) import Lens.Micro.Platform (_Just, (.=), singular) @@ -23,29 +24,29 @@ import Matterhorn.State.NotifyPrefs import Matterhorn.State.Async -onEventEditNotifyPrefs :: V.Event -> MH Bool -onEventEditNotifyPrefs = - handleKeyboardEvent editNotifyPrefsKeybindings (handleEditNotifyPrefsEvent . VtyEvent) +onEventEditNotifyPrefs :: TeamId -> V.Event -> MH Bool +onEventEditNotifyPrefs tId = + handleKeyboardEvent (editNotifyPrefsKeybindings tId) (handleEditNotifyPrefsEvent tId . VtyEvent) -handleEditNotifyPrefsEvent :: BrickEvent Name MHEvent -> MH () -handleEditNotifyPrefsEvent e = do - form <- use (csCurrentTeam.tsNotifyPrefs.singular _Just) +handleEditNotifyPrefsEvent :: TeamId -> BrickEvent Name MHEvent -> MH () +handleEditNotifyPrefsEvent tId e = do + form <- use (csTeam(tId).tsNotifyPrefs.singular _Just) updatedForm <- mh $ handleFormEvent e form - csCurrentTeam.tsNotifyPrefs .= Just updatedForm + csTeam(tId).tsNotifyPrefs .= Just updatedForm -editNotifyPrefsKeybindings :: KeyConfig -> KeyHandlerMap -editNotifyPrefsKeybindings = mkKeybindings editNotifyPrefsKeyHandlers +editNotifyPrefsKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +editNotifyPrefsKeybindings tId = mkKeybindings (editNotifyPrefsKeyHandlers tId) -editNotifyPrefsKeyHandlers :: [KeyEventHandler] -editNotifyPrefsKeyHandlers = - [ mkKb CancelEvent "Close channel notification preferences" exitEditNotifyPrefsMode +editNotifyPrefsKeyHandlers :: TeamId -> [KeyEventHandler] +editNotifyPrefsKeyHandlers tId = + [ mkKb CancelEvent "Close channel notification preferences" $ + exitEditNotifyPrefsMode tId , mkKb FormSubmitEvent "Save channel notification preferences" $ do st <- use id - let form = fromJust $ st^.csCurrentTeam.tsNotifyPrefs - cId = st^.csCurrentChannelId(st^.csCurrentTeamId) - - doAsyncChannelMM Preempt cId - (\s _ -> MM.mmUpdateChannelNotifications cId (myUserId st) (formState form) s) - (\_ _ -> Nothing) - exitEditNotifyPrefsMode + withCurrentChannel tId $ \cId _ -> do + let form = fromJust $ st^.csTeam(tId).tsNotifyPrefs + doAsyncChannelMM Preempt cId + (\s _ -> MM.mmUpdateChannelNotifications cId (myUserId st) (formState form) s) + (\_ _ -> Nothing) + exitEditNotifyPrefsMode tId ] diff --git a/src/Matterhorn/Events/Global.hs b/src/Matterhorn/Events/Global.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Events/Global.hs @@ -0,0 +1,46 @@ +module Matterhorn.Events.Global + ( globalKeybindings + , globalKeyHandlers + ) +where + +import Matterhorn.Command +import Matterhorn.Types +import Matterhorn.State.Channels +import Matterhorn.State.ChannelList +import Matterhorn.State.Teams + +import Matterhorn.Events.Keybindings + + +globalKeybindings :: KeyConfig -> KeyHandlerMap +globalKeybindings = mkKeybindings globalKeyHandlers + +globalKeyHandlers :: [KeyEventHandler] +globalKeyHandlers = + [ mkKb ToggleMessagePreviewEvent "Toggle message preview" + toggleMessagePreview + + , mkKb ToggleChannelListVisibleEvent "Toggle channel list visibility" + toggleChannelListVisibility + + , mkKb ToggleExpandedChannelTopicsEvent "Toggle display of expanded channel topics" + toggleExpandedChannelTopics + + , mkKb NextTeamEvent "Switch to the next available team" + nextTeam + + , mkKb PrevTeamEvent "Switch to the previous available team" + prevTeam + + , mkKb MoveCurrentTeamLeftEvent "Move the current team to the left in the team list" + moveCurrentTeamLeft + + , mkKb MoveCurrentTeamRightEvent "Move the current team to the right in the team list" + moveCurrentTeamRight + + , mkKb + QuitEvent + "Quit" + requestQuit + ] diff --git a/src/Matterhorn/Events/Keybindings.hs b/src/Matterhorn/Events/Keybindings.hs --- a/src/Matterhorn/Events/Keybindings.hs +++ b/src/Matterhorn/Events/Keybindings.hs @@ -186,6 +186,7 @@ EnterFlaggedPostsEvent -> [ meta (key '8') ] ToggleChannelListVisibleEvent -> [ fn 2 ] ToggleExpandedChannelTopicsEvent -> [ fn 3 ] + CycleChannelListSorting -> [ fn 4 ] SelectNextTabEvent -> [ key '\t' ] SelectPreviousTabEvent -> [ kb Vty.KBackTab ] SaveAttachmentEvent -> [ key 's' ] @@ -194,6 +195,8 @@ ScrollDownEvent -> [ kb Vty.KDown ] ScrollLeftEvent -> [ kb Vty.KLeft ] ScrollRightEvent -> [ kb Vty.KRight ] + ChannelListScrollUpEvent -> [ ctrl (kb Vty.KUp) ] + ChannelListScrollDownEvent -> [ ctrl (kb Vty.KDown) ] PageUpEvent -> [ kb Vty.KPageUp ] PageDownEvent -> [ kb Vty.KPageDown ] PageLeftEvent -> [ shift (kb Vty.KLeft) ] diff --git a/src/Matterhorn/Events/LeaveChannelConfirm.hs b/src/Matterhorn/Events/LeaveChannelConfirm.hs --- a/src/Matterhorn/Events/LeaveChannelConfirm.hs +++ b/src/Matterhorn/Events/LeaveChannelConfirm.hs @@ -5,15 +5,17 @@ import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.State.Channels import Matterhorn.Types -onEventLeaveChannelConfirm :: Vty.Event -> MH () -onEventLeaveChannelConfirm (Vty.EvKey k []) = do +onEventLeaveChannelConfirm :: TeamId -> Vty.Event -> MH () +onEventLeaveChannelConfirm tId (Vty.EvKey k []) = do case k of Vty.KChar c | c `elem` ("yY"::String) -> - leaveCurrentChannel + leaveCurrentChannel tId _ -> return () - setMode Main -onEventLeaveChannelConfirm _ = return () + setMode tId Main +onEventLeaveChannelConfirm _ _ = return () diff --git a/src/Matterhorn/Events/Main.hs b/src/Matterhorn/Events/Main.hs --- a/src/Matterhorn/Events/Main.hs +++ b/src/Matterhorn/Events/Main.hs @@ -4,164 +4,160 @@ import Prelude () import Matterhorn.Prelude +import Brick.Main ( viewportScroll, vScrollBy ) import Brick.Widgets.Edit import qualified Graphics.Vty as Vty -import Matterhorn.Command +import Network.Mattermost.Types ( TeamId ) + +import Matterhorn.HelpTopics import Matterhorn.Events.Keybindings import Matterhorn.State.Attachments import Matterhorn.State.ChannelSelect -import Matterhorn.State.ChannelList import Matterhorn.State.Channels import Matterhorn.State.Editing +import Matterhorn.State.Help import Matterhorn.State.MessageSelect import Matterhorn.State.PostListOverlay ( enterFlaggedPostListMode ) -import Matterhorn.State.Teams import Matterhorn.State.UrlSelect import Matterhorn.Types -onEventMain :: Vty.Event -> MH () -onEventMain = - void . handleKeyboardEvent mainKeybindings (\ ev -> do - resetReturnChannel +onEventMain :: TeamId -> Vty.Event -> MH () +onEventMain tId = + void . handleKeyboardEvent (mainKeybindings tId) (\ ev -> do + resetReturnChannel tId case ev of - (Vty.EvPaste bytes) -> handlePaste bytes - _ -> handleEditingInput ev + (Vty.EvPaste bytes) -> handlePaste tId bytes + _ -> handleEditingInput tId ev ) -mainKeybindings :: KeyConfig -> KeyHandlerMap -mainKeybindings = mkKeybindings mainKeyHandlers - -mainKeyHandlers :: [KeyEventHandler] -mainKeyHandlers = - [ mkKb EnterSelectModeEvent - "Select a message to edit/reply/delete" - beginMessageSelect - - , mkKb ReplyRecentEvent - "Reply to the most recent message" - replyToLatestMessage - - , mkKb ToggleMessagePreviewEvent "Toggle message preview" - toggleMessagePreview - - , mkKb ToggleChannelListVisibleEvent "Toggle channel list visibility" - toggleChannelListVisibility - - , mkKb ToggleExpandedChannelTopicsEvent "Toggle display of expanded channel topics" - toggleExpandedChannelTopics - - , mkKb NextTeamEvent "Switch to the next available team" - nextTeam +mainKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +mainKeybindings tId = mkKeybindings (mainKeyHandlers tId) - , mkKb PrevTeamEvent "Switch to the previous available team" - prevTeam +mainKeyHandlers :: TeamId -> [KeyEventHandler] +mainKeyHandlers tId = + [ mkKb ShowHelpEvent + "Show this help screen" $ do + showHelpScreen tId mainHelpTopic - , mkKb MoveCurrentTeamLeftEvent "Move the current team to the left in the team list" - moveCurrentTeamLeft + , mkKb EnterSelectModeEvent + "Select a message to edit/reply/delete" $ + beginMessageSelect tId - , mkKb MoveCurrentTeamRightEvent "Move the current team to the right in the team list" - moveCurrentTeamRight + , mkKb ReplyRecentEvent + "Reply to the most recent message" $ + replyToLatestMessage tId , mkKb InvokeEditorEvent - "Invoke `$EDITOR` to edit the current message" - invokeExternalEditor + "Invoke `$EDITOR` to edit the current message" $ + invokeExternalEditor tId , mkKb EnterFastSelectModeEvent - "Enter fast channel selection mode" - beginChannelSelect - - , mkKb - QuitEvent - "Quit" - requestQuit + "Enter fast channel selection mode" $ + beginChannelSelect tId , staticKb "Tab-complete forward" (Vty.EvKey (Vty.KChar '\t') []) $ - tabComplete Forwards + tabComplete tId Forwards , staticKb "Tab-complete backward" (Vty.EvKey (Vty.KBackTab) []) $ - tabComplete Backwards + tabComplete tId Backwards , mkKb + ChannelListScrollUpEvent + "Scroll up in the channel list" $ do + let vp = viewportScroll $ ChannelList tId + mh $ vScrollBy vp (-1) + + , mkKb + ChannelListScrollDownEvent + "Scroll down in the channel list" $ do + let vp = viewportScroll $ ChannelList tId + mh $ vScrollBy vp 1 + + , mkKb + CycleChannelListSorting + "Cycle through channel list sorting modes" $ + cycleChannelListSortingMode tId + + , mkKb ScrollUpEvent "Scroll up in the channel input history" $ do -- Up in multiline mode does the usual thing; otherwise we -- navigate the history. - isMultiline <- use (csCurrentTeam.tsEditState.cedEphemeral.eesMultiline) + isMultiline <- use (csTeam(tId).tsEditState.cedEphemeral.eesMultiline) case isMultiline of - True -> mhHandleEventLensed (csCurrentTeam.tsEditState.cedEditor) handleEditorEvent + True -> mhHandleEventLensed (csTeam(tId).tsEditState.cedEditor) handleEditorEvent (Vty.EvKey Vty.KUp []) - False -> channelHistoryBackward + False -> channelHistoryBackward tId , mkKb ScrollDownEvent "Scroll down in the channel input history" $ do -- Down in multiline mode does the usual thing; otherwise -- we navigate the history. - isMultiline <- use (csCurrentTeam.tsEditState.cedEphemeral.eesMultiline) + isMultiline <- use (csTeam(tId).tsEditState.cedEphemeral.eesMultiline) case isMultiline of - True -> mhHandleEventLensed (csCurrentTeam.tsEditState.cedEditor) handleEditorEvent + True -> mhHandleEventLensed (csTeam(tId).tsEditState.cedEditor) handleEditorEvent (Vty.EvKey Vty.KDown []) - False -> channelHistoryForward + False -> channelHistoryForward tId , mkKb PageUpEvent "Page up in the channel message list (enters message select mode)" $ do - beginMessageSelect + beginMessageSelect tId , mkKb SelectOldestMessageEvent "Scroll to top of channel message list" $ do - beginMessageSelect - messageSelectFirst + beginMessageSelect tId + messageSelectFirst tId - , mkKb NextChannelEvent "Change to the next channel in the channel list" - nextChannel + , mkKb NextChannelEvent "Change to the next channel in the channel list" $ + nextChannel tId - , mkKb PrevChannelEvent "Change to the previous channel in the channel list" - prevChannel + , mkKb PrevChannelEvent "Change to the previous channel in the channel list" $ + prevChannel tId - , mkKb NextUnreadChannelEvent "Change to the next channel with unread messages or return to the channel marked '~'" - nextUnreadChannel + , mkKb NextUnreadChannelEvent "Change to the next channel with unread messages or return to the channel marked '~'" $ + nextUnreadChannel tId - , mkKb ShowAttachmentListEvent "Show the attachment list" - showAttachmentList + , mkKb ShowAttachmentListEvent "Show the attachment list" $ + showAttachmentList tId , mkKb NextUnreadUserOrChannelEvent - "Change to the next channel with unread messages preferring direct messages" - nextUnreadUserOrChannel + "Change to the next channel with unread messages preferring direct messages" $ + nextUnreadUserOrChannel tId - , mkKb LastChannelEvent "Change to the most recently-focused channel" - recentChannel + , mkKb LastChannelEvent "Change to the most recently-focused channel" $ + recentChannel tId , staticKb "Send the current message" (Vty.EvKey Vty.KEnter []) $ do - isMultiline <- use (csCurrentTeam.tsEditState.cedEphemeral.eesMultiline) + isMultiline <- use (csTeam(tId).tsEditState.cedEphemeral.eesMultiline) case isMultiline of -- Normally, this event causes the current message to -- be sent. But in multiline mode we want to insert a -- newline instead. - True -> handleEditingInput (Vty.EvKey Vty.KEnter []) + True -> handleEditingInput tId (Vty.EvKey Vty.KEnter []) False -> do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - content <- getEditorContent - handleInputSubmission tId cId content + withCurrentChannel tId $ \cId _ -> do + content <- getEditorContent tId + handleInputSubmission tId cId content - , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel" - startUrlSelect + , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel" $ + startUrlSelect tId , mkKb ClearUnreadEvent "Clear the current channel's unread / edited indicators" $ do - tId <- use csCurrentTeamId - clearChannelUnreadStatus =<< use (csCurrentChannelId tId) + withCurrentChannel tId $ \cId _ -> do + clearChannelUnreadStatus cId - , mkKb ToggleMultiLineEvent "Toggle multi-line message compose mode" - toggleMultilineEditing + , mkKb ToggleMultiLineEvent "Toggle multi-line message compose mode" $ + toggleMultilineEditing tId - , mkKb CancelEvent "Cancel autocomplete, message reply, or edit, in that order" - cancelAutocompleteOrReplyOrEdit + , mkKb CancelEvent "Cancel autocomplete, message reply, or edit, in that order" $ + cancelAutocompleteOrReplyOrEdit tId - , mkKb EnterFlaggedPostsEvent "View currently flagged posts" - enterFlaggedPostListMode + , mkKb EnterFlaggedPostsEvent "View currently flagged posts" $ + enterFlaggedPostListMode tId ] diff --git a/src/Matterhorn/Events/ManageAttachments.hs b/src/Matterhorn/Events/ManageAttachments.hs --- a/src/Matterhorn/Events/ManageAttachments.hs +++ b/src/Matterhorn/Events/ManageAttachments.hs @@ -19,6 +19,8 @@ import qualified Graphics.Vty as V import Lens.Micro.Platform ( (?=), (%=), to ) +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types import Matterhorn.Types.KeyEvents import Matterhorn.Events.Keybindings @@ -26,86 +28,86 @@ import Matterhorn.State.Common -onEventManageAttachments :: V.Event -> MH () -onEventManageAttachments e = do - mode <- use (csCurrentTeam.tsMode) +onEventManageAttachments :: TeamId -> V.Event -> MH () +onEventManageAttachments tId e = do + mode <- use (csTeam(tId).tsMode) case mode of - ManageAttachments -> void $ onEventAttachmentList e - ManageAttachmentsBrowseFiles -> onEventBrowseFile e + ManageAttachments -> void $ onEventAttachmentList tId e + ManageAttachmentsBrowseFiles -> onEventBrowseFile tId e _ -> error "BUG: onEventManageAttachments called in invalid mode" -onEventAttachmentList :: V.Event -> MH Bool -onEventAttachmentList = - handleKeyboardEvent attachmentListKeybindings $ - mhHandleEventLensed (csCurrentTeam.tsEditState.cedAttachmentList) L.handleListEvent +onEventAttachmentList :: TeamId -> V.Event -> MH Bool +onEventAttachmentList tId = + handleKeyboardEvent (attachmentListKeybindings tId) $ + mhHandleEventLensed (csTeam(tId).tsEditState.cedAttachmentList) L.handleListEvent -attachmentListKeybindings :: KeyConfig -> KeyHandlerMap -attachmentListKeybindings = mkKeybindings attachmentListKeyHandlers +attachmentListKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +attachmentListKeybindings tId = mkKeybindings (attachmentListKeyHandlers tId) -attachmentListKeyHandlers :: [KeyEventHandler] -attachmentListKeyHandlers = - [ mkKb CancelEvent "Close attachment list" - (setMode Main) +attachmentListKeyHandlers :: TeamId -> [KeyEventHandler] +attachmentListKeyHandlers tId = + [ mkKb CancelEvent "Close attachment list" $ + setMode tId Main , mkKb SelectUpEvent "Move cursor up" $ - mhHandleEventLensed (csCurrentTeam.tsEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KUp []) + mhHandleEventLensed (csTeam(tId).tsEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KUp []) , mkKb SelectDownEvent "Move cursor down" $ - mhHandleEventLensed (csCurrentTeam.tsEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KDown []) - , mkKb AttachmentListAddEvent "Add a new attachment to the attachment list" - showAttachmentFileBrowser - , mkKb AttachmentOpenEvent "Open the selected attachment using the URL open command" - openSelectedAttachment - , mkKb AttachmentListDeleteEvent "Delete the selected attachment from the attachment list" - deleteSelectedAttachment + mhHandleEventLensed (csTeam(tId).tsEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KDown []) + , mkKb AttachmentListAddEvent "Add a new attachment to the attachment list" $ + showAttachmentFileBrowser tId + , mkKb AttachmentOpenEvent "Open the selected attachment using the URL open command" $ + openSelectedAttachment tId + , mkKb AttachmentListDeleteEvent "Delete the selected attachment from the attachment list" $ + deleteSelectedAttachment tId ] -attachmentBrowseKeybindings :: KeyConfig -> KeyHandlerMap -attachmentBrowseKeybindings = mkKeybindings attachmentBrowseKeyHandlers +attachmentBrowseKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +attachmentBrowseKeybindings tId = mkKeybindings (attachmentBrowseKeyHandlers tId) -attachmentBrowseKeyHandlers :: [KeyEventHandler] -attachmentBrowseKeyHandlers = - [ mkKb CancelEvent "Cancel attachment file browse" - cancelAttachmentBrowse - , mkKb AttachmentOpenEvent "Open the selected file using the URL open command" - openSelectedBrowserEntry +attachmentBrowseKeyHandlers :: TeamId -> [KeyEventHandler] +attachmentBrowseKeyHandlers tId = + [ mkKb CancelEvent "Cancel attachment file browse" $ + cancelAttachmentBrowse tId + , mkKb AttachmentOpenEvent "Open the selected file using the URL open command" $ + openSelectedBrowserEntry tId , mkKb FileBrowserBeginSearchEvent "Begin search for name in list" $ - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserBeginSearch , mkKb FileBrowserSelectEnterEvent "Select file or enter directory" $ do - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserSelectEnter - withFileBrowser (tryAddAttachment . FB.fileBrowserSelection) + withFileBrowser tId (tryAddAttachment tId . FB.fileBrowserSelection) , mkKb FileBrowserSelectCurrentEvent "Select file" $ - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserSelectCurrent , mkKb FileBrowserListPageUpEvent "Move cursor one page up" $ - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserListPageUp , mkKb FileBrowserListPageDownEvent "Move cursor one page down" $ - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserListPageDown , mkKb FileBrowserListHalfPageUpEvent "Move cursor one-half page up" $ - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserListHalfPageUp , mkKb FileBrowserListHalfPageDownEvent "Move cursor one-half page down" $ - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserListHalfPageDown , mkKb FileBrowserListTopEvent "Move cursor to top of list" $ - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserListTop , mkKb FileBrowserListBottomEvent "Move cursor to bottom of list" $ - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserListBottom , mkKb FileBrowserListNextEvent "Move cursor down" $ - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserListNext , mkKb FileBrowserListPrevEvent "Move cursor up" $ - mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser) FB.actionFileBrowserListPrev ] -withFileBrowser :: ((FB.FileBrowser Name) -> MH ()) -> MH () -withFileBrowser f = do - use (csCurrentTeam.tsEditState.cedFileBrowser) >>= \case +withFileBrowser :: TeamId -> ((FB.FileBrowser Name) -> MH ()) -> MH () +withFileBrowser tId f = do + use (csTeam(tId).tsEditState.cedFileBrowser) >>= \case Nothing -> do -- The widget has not been created yet. This should -- normally not occur, because the ManageAttachments @@ -114,66 +116,65 @@ -- This could therefore be implemented as an `error "BUG: -- ..."` handler, but the more benign approach is to -- simply create an available FileBrowser at this stage. - tId <- use csCurrentTeamId new_b <- liftIO $ FB.newFileBrowser FB.selectNonDirectories (AttachmentFileBrowser tId) Nothing - csCurrentTeam.tsEditState.cedFileBrowser ?= new_b + csTeam(tId).tsEditState.cedFileBrowser ?= new_b f new_b Just b -> f b -openSelectedAttachment :: MH () -openSelectedAttachment = do - cur <- use (csCurrentTeam.tsEditState.cedAttachmentList.to L.listSelectedElement) +openSelectedAttachment :: TeamId -> MH () +openSelectedAttachment tId = do + cur <- use (csTeam(tId).tsEditState.cedAttachmentList.to L.listSelectedElement) case cur of Nothing -> return () Just (_, entry) -> void $ openFilePath (FB.fileInfoFilePath $ attachmentDataFileInfo entry) -openSelectedBrowserEntry :: MH () -openSelectedBrowserEntry = withFileBrowser $ \b -> +openSelectedBrowserEntry :: TeamId -> MH () +openSelectedBrowserEntry tId = withFileBrowser tId $ \b -> case FB.fileBrowserCursor b of Nothing -> return () Just entry -> void $ openFilePath (FB.fileInfoFilePath entry) -onEventBrowseFile :: V.Event -> MH () -onEventBrowseFile e = do - withFileBrowser $ \b -> do +onEventBrowseFile :: TeamId -> V.Event -> MH () +onEventBrowseFile tId e = do + withFileBrowser tId $ \b -> do case FB.fileBrowserIsSearching b of False -> - void $ handleKeyboardEvent attachmentBrowseKeybindings handleFileBrowserEvent e + void $ handleKeyboardEvent (attachmentBrowseKeybindings tId) (handleFileBrowserEvent tId) e True -> - handleFileBrowserEvent e + handleFileBrowserEvent tId e -- n.b. the FileBrowser may have been updated above, so re-acquire it - withFileBrowser $ \b -> do + withFileBrowser tId $ \b -> do case FB.fileBrowserException b of Nothing -> return () Just ex -> do mhLog LogError $ T.pack $ "FileBrowser exception: " <> show ex -cancelAttachmentBrowse :: MH () -cancelAttachmentBrowse = do - es <- use (csCurrentTeam.tsEditState.cedAttachmentList.L.listElementsL) +cancelAttachmentBrowse :: TeamId -> MH () +cancelAttachmentBrowse tId = do + es <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listElementsL) case length es of - 0 -> setMode Main - _ -> setMode ManageAttachments + 0 -> setMode tId Main + _ -> setMode tId ManageAttachments -handleFileBrowserEvent :: V.Event -> MH () -handleFileBrowserEvent e = do +handleFileBrowserEvent :: TeamId -> V.Event -> MH () +handleFileBrowserEvent tId e = do let fbHandle ev = sequence . (fmap (FB.handleFileBrowserEvent ev)) - mhHandleEventLensed (csCurrentTeam.tsEditState.cedFileBrowser) fbHandle e + mhHandleEventLensed (csTeam(tId).tsEditState.cedFileBrowser) fbHandle e -- TODO: Check file browser exception state - withFileBrowser $ \b -> - tryAddAttachment $ FB.fileBrowserSelection b + withFileBrowser tId $ \b -> + tryAddAttachment tId $ FB.fileBrowserSelection b -deleteSelectedAttachment :: MH () -deleteSelectedAttachment = do - es <- use (csCurrentTeam.tsEditState.cedAttachmentList.L.listElementsL) - mSel <- use (csCurrentTeam.tsEditState.cedAttachmentList.to L.listSelectedElement) +deleteSelectedAttachment :: TeamId -> MH () +deleteSelectedAttachment tId = do + es <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listElementsL) + mSel <- use (csTeam(tId).tsEditState.cedAttachmentList.to L.listSelectedElement) case mSel of Nothing -> return () Just (pos, _) -> do - oldIdx <- use (csCurrentTeam.tsEditState.cedAttachmentList.L.listSelectedL) + oldIdx <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listSelectedL) let idx = if Vector.length es == 1 then Nothing else case oldIdx of @@ -181,7 +182,7 @@ Just old -> if pos >= old then Just $ pos - 1 else Just pos - csCurrentTeam.tsEditState.cedAttachmentList %= L.listReplace (deleteAt pos es) idx + csTeam(tId).tsEditState.cedAttachmentList %= L.listReplace (deleteAt pos es) idx deleteAt :: Int -> Vector.Vector a -> Vector.Vector a deleteAt p as | p < 0 || p >= length as = as diff --git a/src/Matterhorn/Events/MessageSelect.hs b/src/Matterhorn/Events/MessageSelect.hs --- a/src/Matterhorn/Events/MessageSelect.hs +++ b/src/Matterhorn/Events/MessageSelect.hs @@ -12,6 +12,8 @@ import qualified Data.Text as T import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Events.Keybindings import Matterhorn.State.MessageSelect import Matterhorn.State.ReactionEmojiListOverlay @@ -21,74 +23,73 @@ messagesPerPageOperation :: Int messagesPerPageOperation = 10 -onEventMessageSelect :: Vty.Event -> MH () -onEventMessageSelect = - void . handleKeyboardEvent messageSelectKeybindings (const $ return ()) +onEventMessageSelect :: TeamId -> Vty.Event -> MH () +onEventMessageSelect tId = + void . handleKeyboardEvent (messageSelectKeybindings tId) (const $ return ()) -onEventMessageSelectDeleteConfirm :: Vty.Event -> MH () -onEventMessageSelectDeleteConfirm (Vty.EvKey (Vty.KChar 'y') []) = do - deleteSelectedMessage - setMode Main -onEventMessageSelectDeleteConfirm _ = - setMode Main +onEventMessageSelectDeleteConfirm :: TeamId -> Vty.Event -> MH () +onEventMessageSelectDeleteConfirm tId (Vty.EvKey (Vty.KChar 'y') []) = do + deleteSelectedMessage tId + setMode tId Main +onEventMessageSelectDeleteConfirm tId _ = do + setMode tId Main -messageSelectKeybindings :: KeyConfig -> KeyHandlerMap -messageSelectKeybindings = mkKeybindings messageSelectKeyHandlers +messageSelectKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +messageSelectKeybindings tId = mkKeybindings (messageSelectKeyHandlers tId) -messageSelectKeyHandlers :: [KeyEventHandler] -messageSelectKeyHandlers = - [ mkKb CancelEvent "Cancel message selection" $ - setMode Main +messageSelectKeyHandlers :: TeamId -> [KeyEventHandler] +messageSelectKeyHandlers tId = + [ mkKb CancelEvent "Cancel message selection" $ do + setMode tId Main - , mkKb SelectUpEvent "Select the previous message" messageSelectUp - , mkKb SelectDownEvent "Select the next message" messageSelectDown - , mkKb ScrollTopEvent "Scroll to top and select the oldest message" - messageSelectFirst - , mkKb ScrollBottomEvent "Scroll to bottom and select the latest message" - messageSelectLast + , mkKb SelectUpEvent "Select the previous message" $ messageSelectUp tId + , mkKb SelectDownEvent "Select the next message" $ messageSelectDown tId + , mkKb ScrollTopEvent "Scroll to top and select the oldest message" $ + messageSelectFirst tId + , mkKb ScrollBottomEvent "Scroll to bottom and select the latest message" $ + messageSelectLast tId , mkKb PageUpEvent (T.pack $ "Move the cursor up by " <> show messagesPerPageOperation <> " messages") - (messageSelectUpBy messagesPerPageOperation) + (messageSelectUpBy tId messagesPerPageOperation) , mkKb PageDownEvent (T.pack $ "Move the cursor down by " <> show messagesPerPageOperation <> " messages") - (messageSelectDownBy messagesPerPageOperation) - - , mkKb OpenMessageURLEvent "Open all URLs in the selected message" - openSelectedMessageURLs + (messageSelectDownBy tId messagesPerPageOperation) - , mkKb ReplyMessageEvent "Begin composing a reply to the selected message" - beginReplyCompose + , mkKb OpenMessageURLEvent "Open all URLs in the selected message" $ + openSelectedMessageURLs tId - , mkKb EditMessageEvent "Begin editing the selected message" - beginEditMessage + , mkKb ReplyMessageEvent "Begin composing a reply to the selected message" $ + beginReplyCompose tId - , mkKb DeleteMessageEvent "Delete the selected message (with confirmation)" - beginConfirmDeleteSelectedMessage + , mkKb EditMessageEvent "Begin editing the selected message" $ + beginEditMessage tId - , mkKb YankMessageEvent "Copy a verbatim section or message to the clipboard" - yankSelectedMessageVerbatim + , mkKb DeleteMessageEvent "Delete the selected message (with confirmation)" $ + beginConfirmDeleteSelectedMessage tId - , mkKb YankWholeMessageEvent "Copy an entire message to the clipboard" - yankSelectedMessage + , mkKb YankMessageEvent "Copy a verbatim section or message to the clipboard" $ + yankSelectedMessageVerbatim tId - , mkKb PinMessageEvent "Toggle whether the selected message is pinned" - pinSelectedMessage + , mkKb YankWholeMessageEvent "Copy an entire message to the clipboard" $ + yankSelectedMessage tId - , mkKb FlagMessageEvent "Flag the selected message" - flagSelectedMessage + , mkKb PinMessageEvent "Toggle whether the selected message is pinned" $ + pinSelectedMessage tId - , mkKb ViewMessageEvent "View the selected message" - viewSelectedMessage + , mkKb FlagMessageEvent "Flag the selected message" $ + flagSelectedMessage tId - , mkKb FillGapEvent "Fetch messages for the selected gap" - fillSelectedGap + , mkKb ViewMessageEvent "View the selected message" $ + viewSelectedMessage tId - , mkKb CopyPostLinkEvent "Copy a post's link to the clipboard" - copyPostLink + , mkKb FillGapEvent "Fetch messages for the selected gap" $ + fillSelectedGap tId - , mkKb ReactToMessageEvent "Post a reaction to the selected message" - enterReactionEmojiListOverlayMode + , mkKb ReactToMessageEvent "Post a reaction to the selected message" $ + enterReactionEmojiListOverlayMode tId + , mkKb CopyPostLinkEvent "Copy a post's link to the clipboard" $ + copyPostLink tId ] diff --git a/src/Matterhorn/Events/Mouse.hs b/src/Matterhorn/Events/Mouse.hs --- a/src/Matterhorn/Events/Mouse.hs +++ b/src/Matterhorn/Events/Mouse.hs @@ -8,6 +8,8 @@ import Brick +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.State.Channels import Matterhorn.State.Teams ( setTeam ) import Matterhorn.State.ListOverlay ( listOverlayActivate ) @@ -20,14 +22,14 @@ -- The top-level mouse click handler. This dispatches to specific -- handlers for some modes, or the global mouse handler when the mode is -- not important (or when it is important that we ignore the mode). -mouseHandlerByMode :: Mode -> BrickEvent Name MHEvent -> MH () -mouseHandlerByMode mode = +mouseHandlerByMode :: TeamId -> Mode -> BrickEvent Name MHEvent -> MH () +mouseHandlerByMode tId mode = case mode of - ChannelSelect -> channelSelectMouseHandler - EditNotifyPrefs -> handleEditNotifyPrefsEvent - ReactionEmojiListOverlay -> reactionEmojiListMouseHandler + ChannelSelect -> channelSelectMouseHandler tId + EditNotifyPrefs -> handleEditNotifyPrefsEvent tId + ReactionEmojiListOverlay -> reactionEmojiListMouseHandler tId UrlSelect -> urlListMouseHandler - _ -> globalMouseHandler + _ -> globalMouseHandler tId -- Handle global mouse click events (when mode is not important). -- @@ -51,14 +53,14 @@ -- accidentally on a grayed-out URL (in a message, say) next to a modal -- dialog box and then see the URL get opened. That would be weird, but -- it isn't the end of the world. -globalMouseHandler :: BrickEvent Name MHEvent -> MH () -globalMouseHandler (MouseDown n _ _ _) = +globalMouseHandler :: TeamId -> BrickEvent Name MHEvent -> MH () +globalMouseHandler tId (MouseDown n _ _ _) = do case n of ClickableChannelListEntry channelId -> do - whenMode Main $ do - resetReturnChannel - setFocus channelId - setMode Main + whenMode tId Main $ do + resetReturnChannel tId + setFocus tId channelId + setMode tId Main ClickableTeamListEntry teamId -> -- We deliberately handle this event in all modes; this -- allows us to switch the UI to another team regardless of @@ -70,18 +72,28 @@ ClickableURL _ _ t -> void $ openLinkTarget t ClickableUsernameInMessage _ _ username -> - changeChannelByName $ addUserSigil username + changeChannelByName tId $ addUserSigil username ClickableUsername _ _ username -> - changeChannelByName $ addUserSigil username + changeChannelByName tId $ addUserSigil username ClickableAttachment fId -> void $ openLinkTarget $ LinkFileId fId ClickableReactionInMessage pId t uIds -> void $ toggleReaction pId t uIds ClickableReaction pId t uIds -> void $ toggleReaction pId t uIds + ClickableChannelListGroupHeading label -> + toggleChannelListGroupVisibility label + VScrollBar e vpName -> do + let vp = viewportScroll vpName + mh $ case e of + SBHandleBefore -> vScrollBy vp (-1) + SBHandleAfter -> vScrollBy vp 1 + SBTroughBefore -> vScrollPage vp Up + SBTroughAfter -> vScrollPage vp Down + SBBar -> return () _ -> return () -globalMouseHandler _ = +globalMouseHandler _ _ = return () urlListMouseHandler :: BrickEvent Name MHEvent -> MH () @@ -90,15 +102,15 @@ urlListMouseHandler _ = return () -channelSelectMouseHandler :: BrickEvent Name MHEvent -> MH () -channelSelectMouseHandler (MouseDown (ChannelSelectEntry match) _ _ _) = do - setMode Main - setFocus $ channelListEntryChannelId $ matchEntry match -channelSelectMouseHandler _ = +channelSelectMouseHandler :: TeamId -> BrickEvent Name MHEvent -> MH () +channelSelectMouseHandler tId (MouseDown (ChannelSelectEntry match) _ _ _) = do + setMode tId Main + setFocus tId $ channelListEntryChannelId $ matchEntry match +channelSelectMouseHandler _ _ = return () -reactionEmojiListMouseHandler :: BrickEvent Name MHEvent -> MH () -reactionEmojiListMouseHandler (MouseDown (ReactionEmojiListOverlayEntry val) _ _ _) = - listOverlayActivate (csCurrentTeam.tsReactionEmojiListOverlay) val -reactionEmojiListMouseHandler _ = +reactionEmojiListMouseHandler :: TeamId -> BrickEvent Name MHEvent -> MH () +reactionEmojiListMouseHandler tId (MouseDown (ReactionEmojiListOverlayEntry val) _ _ _) = + listOverlayActivate tId (csTeam(tId).tsReactionEmojiListOverlay) val +reactionEmojiListMouseHandler _ _ = return () diff --git a/src/Matterhorn/Events/PostListOverlay.hs b/src/Matterhorn/Events/PostListOverlay.hs --- a/src/Matterhorn/Events/PostListOverlay.hs +++ b/src/Matterhorn/Events/PostListOverlay.hs @@ -5,24 +5,26 @@ import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types import Matterhorn.Events.Keybindings import Matterhorn.State.PostListOverlay -onEventPostListOverlay :: Vty.Event -> MH () -onEventPostListOverlay = - void . handleKeyboardEvent postListOverlayKeybindings (const $ return ()) +onEventPostListOverlay :: TeamId -> Vty.Event -> MH () +onEventPostListOverlay tId = + void . handleKeyboardEvent (postListOverlayKeybindings tId) (const $ return ()) -- | The keybindings we want to use while viewing a post list overlay -postListOverlayKeybindings :: KeyConfig -> KeyHandlerMap -postListOverlayKeybindings = mkKeybindings postListOverlayKeyHandlers +postListOverlayKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +postListOverlayKeybindings tId = mkKeybindings (postListOverlayKeyHandlers tId) -postListOverlayKeyHandlers :: [KeyEventHandler] -postListOverlayKeyHandlers = - [ mkKb CancelEvent "Exit post browsing" exitPostListMode - , mkKb SelectUpEvent "Select the previous message" postListSelectUp - , mkKb SelectDownEvent "Select the next message" postListSelectDown - , mkKb FlagMessageEvent "Toggle the selected message flag" postListUnflagSelected - , mkKb ActivateListItemEvent "Jump to and select current message" postListJumpToCurrent +postListOverlayKeyHandlers :: TeamId -> [KeyEventHandler] +postListOverlayKeyHandlers tId = + [ mkKb CancelEvent "Exit post browsing" $ exitPostListMode tId + , mkKb SelectUpEvent "Select the previous message" $ postListSelectUp tId + , mkKb SelectDownEvent "Select the next message" $ postListSelectDown tId + , mkKb FlagMessageEvent "Toggle the selected message flag" $ postListUnflagSelected tId + , mkKb ActivateListItemEvent "Jump to and select current message" $ postListJumpToCurrent tId ] diff --git a/src/Matterhorn/Events/ReactionEmojiListOverlay.hs b/src/Matterhorn/Events/ReactionEmojiListOverlay.hs --- a/src/Matterhorn/Events/ReactionEmojiListOverlay.hs +++ b/src/Matterhorn/Events/ReactionEmojiListOverlay.hs @@ -10,33 +10,35 @@ import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Events.Keybindings import Matterhorn.State.ReactionEmojiListOverlay import Matterhorn.State.ListOverlay import Matterhorn.Types -onEventReactionEmojiListOverlay :: Vty.Event -> MH () -onEventReactionEmojiListOverlay = - void . onEventListOverlay (csCurrentTeam.tsReactionEmojiListOverlay) - reactionEmojiListOverlayKeybindings +onEventReactionEmojiListOverlay :: TeamId -> Vty.Event -> MH () +onEventReactionEmojiListOverlay tId = + void . onEventListOverlay tId (csTeam(tId).tsReactionEmojiListOverlay) + (reactionEmojiListOverlayKeybindings tId) -- | The keybindings we want to use while viewing an emoji list overlay -reactionEmojiListOverlayKeybindings :: KeyConfig -> KeyHandlerMap -reactionEmojiListOverlayKeybindings = mkKeybindings reactionEmojiListOverlayKeyHandlers +reactionEmojiListOverlayKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +reactionEmojiListOverlayKeybindings tId = mkKeybindings (reactionEmojiListOverlayKeyHandlers tId) -reactionEmojiListOverlayKeyHandlers :: [KeyEventHandler] -reactionEmojiListOverlayKeyHandlers = +reactionEmojiListOverlayKeyHandlers :: TeamId -> [KeyEventHandler] +reactionEmojiListOverlayKeyHandlers tId = [ mkKb CancelEvent "Close the emoji search window" - (exitListOverlay (csCurrentTeam.tsReactionEmojiListOverlay)) - , mkKb SearchSelectUpEvent "Select the previous emoji" - reactionEmojiListSelectUp - , mkKb SearchSelectDownEvent "Select the next emoji" - reactionEmojiListSelectDown - , mkKb PageDownEvent "Page down in the emoji list" - reactionEmojiListPageDown - , mkKb PageUpEvent "Page up in the emoji list" - reactionEmojiListPageUp + (exitListOverlay tId (csTeam(tId).tsReactionEmojiListOverlay)) + , mkKb SearchSelectUpEvent "Select the previous emoji" $ + reactionEmojiListSelectUp tId + , mkKb SearchSelectDownEvent "Select the next emoji" $ + reactionEmojiListSelectDown tId + , mkKb PageDownEvent "Page down in the emoji list" $ + reactionEmojiListPageDown tId + , mkKb PageUpEvent "Page up in the emoji list" $ + reactionEmojiListPageUp tId , mkKb ActivateListItemEvent "Post the selected emoji reaction" - (listOverlayActivateCurrent (csCurrentTeam.tsReactionEmojiListOverlay)) + (listOverlayActivateCurrent tId (csTeam(tId).tsReactionEmojiListOverlay)) ] diff --git a/src/Matterhorn/Events/SaveAttachmentWindow.hs b/src/Matterhorn/Events/SaveAttachmentWindow.hs --- a/src/Matterhorn/Events/SaveAttachmentWindow.hs +++ b/src/Matterhorn/Events/SaveAttachmentWindow.hs @@ -14,6 +14,8 @@ import Lens.Micro.Platform ( (%=) ) import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types import Matterhorn.State.Common ( postInfoMessage, fetchFileAtPath , doAsyncWith, AsyncPriority(Normal) @@ -21,20 +23,24 @@ ) -onEventSaveAttachmentWindow :: Vty.Event -> MH () -onEventSaveAttachmentWindow (Vty.EvKey (Vty.KChar '\t') []) = - csCurrentTeam.tsSaveAttachmentDialog.attachmentPathDialogFocus %= focusNext -onEventSaveAttachmentWindow (Vty.EvKey Vty.KBackTab []) = - csCurrentTeam.tsSaveAttachmentDialog.attachmentPathDialogFocus %= focusPrev -onEventSaveAttachmentWindow (Vty.EvKey Vty.KEnter []) = do - f <- use (csCurrentTeam.tsSaveAttachmentDialog.attachmentPathDialogFocus) +onEventSaveAttachmentWindow :: TeamId -> Vty.Event -> MH () +onEventSaveAttachmentWindow tId (Vty.EvKey (Vty.KChar '\t') []) = + csTeam(tId).tsSaveAttachmentDialog.attachmentPathDialogFocus %= focusNext +onEventSaveAttachmentWindow tId (Vty.EvKey Vty.KBackTab []) = + csTeam(tId).tsSaveAttachmentDialog.attachmentPathDialogFocus %= focusPrev +onEventSaveAttachmentWindow tId (Vty.EvKey Vty.KEnter []) = do + f <- use (csTeam(tId).tsSaveAttachmentDialog.attachmentPathDialogFocus) session <- getSession - mode <- use (csCurrentTeam.tsMode) + mode <- use (csTeam(tId).tsMode) - let SaveAttachmentWindow link = mode - LinkFileId fId = link^.linkTarget + let link = case mode of + SaveAttachmentWindow l -> l + _ -> error $ "BUG: invalid mode " <> show mode <> " in onEventSaveAttachmentWindow" + fId = case link^.linkTarget of + LinkFileId i -> i + _ -> error $ "BUG: invalid link target " <> show (link^.linkTarget) <> " in onEventSaveAttachmentWindow" save = do - ed <- use (csCurrentTeam.tsSaveAttachmentDialog.attachmentPathEditor) + ed <- use (csTeam(tId).tsSaveAttachmentDialog.attachmentPathEditor) let path = T.unpack $ T.strip $ T.concat $ getEditContents ed when (not $ null path) $ do @@ -46,20 +52,20 @@ postErrorMessage' $ T.pack $ "Error saving to " <> path <> ": " <> show e Right () -> postInfoMessage $ T.pack $ "Attachment saved to " <> path - setMode UrlSelect + setMode tId UrlSelect case focusGetCurrent f of Just (AttachmentPathSaveButton {}) -> save Just (AttachmentPathEditor {}) -> save - Just (AttachmentPathCancelButton {}) -> setMode UrlSelect - _ -> setMode UrlSelect -onEventSaveAttachmentWindow (Vty.EvKey Vty.KEsc []) = do - setMode UrlSelect -onEventSaveAttachmentWindow e = do - f <- use (csCurrentTeam.tsSaveAttachmentDialog.attachmentPathDialogFocus) + Just (AttachmentPathCancelButton {}) -> setMode tId UrlSelect + _ -> setMode tId UrlSelect +onEventSaveAttachmentWindow tId (Vty.EvKey Vty.KEsc []) = do + setMode tId UrlSelect +onEventSaveAttachmentWindow tId e = do + f <- use (csTeam(tId).tsSaveAttachmentDialog.attachmentPathDialogFocus) case focusGetCurrent f of Just (AttachmentPathEditor {}) -> - mhHandleEventLensed (csCurrentTeam.tsSaveAttachmentDialog.attachmentPathEditor) + mhHandleEventLensed (csTeam(tId).tsSaveAttachmentDialog.attachmentPathEditor) handleEditorEvent e _ -> return () diff --git a/src/Matterhorn/Events/ShowHelp.hs b/src/Matterhorn/Events/ShowHelp.hs --- a/src/Matterhorn/Events/ShowHelp.hs +++ b/src/Matterhorn/Events/ShowHelp.hs @@ -6,22 +6,24 @@ import Brick import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Constants import Matterhorn.Events.Keybindings import Matterhorn.Types -onEventShowHelp :: Vty.Event -> MH Bool -onEventShowHelp = - handleKeyboardEvent helpKeybindings $ \ e -> case e of - Vty.EvKey _ _ -> popMode +onEventShowHelp :: TeamId -> Vty.Event -> MH Bool +onEventShowHelp tId = + handleKeyboardEvent (helpKeybindings tId) $ \ e -> case e of + Vty.EvKey _ _ -> popMode tId _ -> return () -helpKeybindings :: KeyConfig -> KeyHandlerMap -helpKeybindings = mkKeybindings helpKeyHandlers +helpKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +helpKeybindings tId = mkKeybindings (helpKeyHandlers tId) -helpKeyHandlers :: [KeyEventHandler] -helpKeyHandlers = +helpKeyHandlers :: TeamId -> [KeyEventHandler] +helpKeyHandlers tId = [ mkKb ScrollUpEvent "Scroll up" $ mh $ vScrollBy (viewportScroll HelpViewport) (-1) , mkKb ScrollDownEvent "Scroll down" $ @@ -31,14 +33,14 @@ , mkKb PageDownEvent "Page down" $ mh $ vScrollBy (viewportScroll HelpViewport) (1 * pageAmount) , mkKb CancelEvent "Return to the previous interface" $ - popMode + popMode tId , mkKb ScrollBottomEvent "Scroll to the end of the help" $ mh $ vScrollToEnd (viewportScroll HelpViewport) , mkKb ScrollTopEvent "Scroll to the beginning of the help" $ mh $ vScrollToBeginning (viewportScroll HelpViewport) ] -popMode :: MH () -popMode = do - ShowHelp _ prevMode <- use (csCurrentTeam.tsMode) - setMode prevMode +popMode :: TeamId -> MH () +popMode tId = do + ShowHelp _ prevMode <- use (csTeam(tId).tsMode) + setMode tId prevMode diff --git a/src/Matterhorn/Events/TabbedWindow.hs b/src/Matterhorn/Events/TabbedWindow.hs --- a/src/Matterhorn/Events/TabbedWindow.hs +++ b/src/Matterhorn/Events/TabbedWindow.hs @@ -12,17 +12,20 @@ import qualified Graphics.Vty as Vty import Lens.Micro.Platform ( Lens', (.=) ) +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types import Matterhorn.Types.KeyEvents import Matterhorn.Events.Keybindings handleTabbedWindowEvent :: (Show a, Eq a) => Lens' ChatState (TabbedWindow a) + -> TeamId -> Vty.Event -> MH Bool -handleTabbedWindowEvent target e = do +handleTabbedWindowEvent target tId e = do w <- use target - handleKeyboardEvent (tabbedWindowKeybindings target) (forwardEvent w) e + handleKeyboardEvent (tabbedWindowKeybindings target tId) (forwardEvent w) e forwardEvent :: (Show a, Eq a) => TabbedWindow a @@ -34,17 +37,19 @@ tabbedWindowKeybindings :: (Show a, Eq a) => Lens' ChatState (TabbedWindow a) + -> TeamId -> KeyConfig -> KeyHandlerMap -tabbedWindowKeybindings target = mkKeybindings $ tabbedWindowKeyHandlers target +tabbedWindowKeybindings target tId = mkKeybindings $ tabbedWindowKeyHandlers tId target tabbedWindowKeyHandlers :: (Show a, Eq a) - => Lens' ChatState (TabbedWindow a) + => TeamId + -> Lens' ChatState (TabbedWindow a) -> [KeyEventHandler] -tabbedWindowKeyHandlers target = +tabbedWindowKeyHandlers tId target = [ mkKb CancelEvent "Close window" $ do w <- use target - setMode (twReturnMode w) + setMode tId (twReturnMode w) , mkKb SelectNextTabEvent "Select next tab" $ do w' <- tabbedWindowNextTab =<< use target diff --git a/src/Matterhorn/Events/ThemeListOverlay.hs b/src/Matterhorn/Events/ThemeListOverlay.hs --- a/src/Matterhorn/Events/ThemeListOverlay.hs +++ b/src/Matterhorn/Events/ThemeListOverlay.hs @@ -5,33 +5,35 @@ import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Events.Keybindings import Matterhorn.State.ThemeListOverlay import Matterhorn.State.ListOverlay import Matterhorn.Types -onEventThemeListOverlay :: Vty.Event -> MH () -onEventThemeListOverlay = - void . onEventListOverlay (csCurrentTeam.tsThemeListOverlay) - themeListOverlayKeybindings +onEventThemeListOverlay :: TeamId -> Vty.Event -> MH () +onEventThemeListOverlay tId = + void . onEventListOverlay tId (csTeam(tId).tsThemeListOverlay) + (themeListOverlayKeybindings tId) -- | The keybindings we want to use while viewing a user list overlay -themeListOverlayKeybindings :: KeyConfig -> KeyHandlerMap -themeListOverlayKeybindings = mkKeybindings themeListOverlayKeyHandlers +themeListOverlayKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +themeListOverlayKeybindings tId = mkKeybindings (themeListOverlayKeyHandlers tId) -themeListOverlayKeyHandlers :: [KeyEventHandler] -themeListOverlayKeyHandlers = +themeListOverlayKeyHandlers :: TeamId -> [KeyEventHandler] +themeListOverlayKeyHandlers tId = [ mkKb CancelEvent "Close the theme list" - (exitListOverlay (csCurrentTeam.tsThemeListOverlay)) - , mkKb SearchSelectUpEvent "Select the previous theme" - themeListSelectUp - , mkKb SearchSelectDownEvent "Select the next theme" - themeListSelectDown - , mkKb PageDownEvent "Page down in the theme list" - themeListPageDown - , mkKb PageUpEvent "Page up in the theme list" - themeListPageUp + (exitListOverlay tId (csTeam(tId).tsThemeListOverlay)) + , mkKb SearchSelectUpEvent "Select the previous theme" $ + themeListSelectUp tId + , mkKb SearchSelectDownEvent "Select the next theme" $ + themeListSelectDown tId + , mkKb PageDownEvent "Page down in the theme list" $ + themeListPageDown tId + , mkKb PageUpEvent "Page up in the theme list" $ + themeListPageUp tId , mkKb ActivateListItemEvent "Switch to the selected color theme" - (listOverlayActivateCurrent (csCurrentTeam.tsThemeListOverlay)) + (listOverlayActivateCurrent tId (csTeam(tId).tsThemeListOverlay)) ] diff --git a/src/Matterhorn/Events/UrlSelect.hs b/src/Matterhorn/Events/UrlSelect.hs --- a/src/Matterhorn/Events/UrlSelect.hs +++ b/src/Matterhorn/Events/UrlSelect.hs @@ -6,38 +6,40 @@ import Brick.Widgets.List import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Events.Keybindings import Matterhorn.State.UrlSelect import Matterhorn.State.SaveAttachmentWindow import Matterhorn.Types -onEventUrlSelect :: Vty.Event -> MH Bool -onEventUrlSelect = - handleKeyboardEvent urlSelectKeybindings $ \ ev -> - mhHandleEventLensed (csCurrentTeam.tsUrlList) handleListEvent ev +onEventUrlSelect :: TeamId -> Vty.Event -> MH Bool +onEventUrlSelect tId = + handleKeyboardEvent (urlSelectKeybindings tId) $ \ ev -> + mhHandleEventLensed (csTeam(tId).tsUrlList) handleListEvent ev -urlSelectKeybindings :: KeyConfig -> KeyHandlerMap -urlSelectKeybindings = mkKeybindings urlSelectKeyHandlers +urlSelectKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +urlSelectKeybindings tId = mkKeybindings (urlSelectKeyHandlers tId) -urlSelectKeyHandlers :: [KeyEventHandler] -urlSelectKeyHandlers = +urlSelectKeyHandlers :: TeamId -> [KeyEventHandler] +urlSelectKeyHandlers tId = [ staticKb "Open the selected URL, if any" (Vty.EvKey Vty.KEnter []) $ - openSelectedURL + openSelectedURL tId - , mkKb SaveAttachmentEvent "Save the selected attachment" - openSaveAttachmentWindow + , mkKb SaveAttachmentEvent "Save the selected attachment" $ + openSaveAttachmentWindow tId - , mkKb CancelEvent "Cancel URL selection" stopUrlSelect + , mkKb CancelEvent "Cancel URL selection" $ stopUrlSelect tId , mkKb SelectUpEvent "Move cursor up" $ - mhHandleEventLensed (csCurrentTeam.tsUrlList) handleListEvent (Vty.EvKey Vty.KUp []) + mhHandleEventLensed (csTeam(tId).tsUrlList) handleListEvent (Vty.EvKey Vty.KUp []) , mkKb SelectDownEvent "Move cursor down" $ - mhHandleEventLensed (csCurrentTeam.tsUrlList) handleListEvent (Vty.EvKey Vty.KDown []) + mhHandleEventLensed (csTeam(tId).tsUrlList) handleListEvent (Vty.EvKey Vty.KDown []) , staticKb "Cancel URL selection" - (Vty.EvKey (Vty.KChar 'q') []) $ stopUrlSelect + (Vty.EvKey (Vty.KChar 'q') []) $ stopUrlSelect tId ] diff --git a/src/Matterhorn/Events/UserListOverlay.hs b/src/Matterhorn/Events/UserListOverlay.hs --- a/src/Matterhorn/Events/UserListOverlay.hs +++ b/src/Matterhorn/Events/UserListOverlay.hs @@ -5,26 +5,28 @@ import qualified Graphics.Vty as Vty +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Events.Keybindings import Matterhorn.State.UserListOverlay import Matterhorn.State.ListOverlay import Matterhorn.Types -onEventUserListOverlay :: Vty.Event -> MH () -onEventUserListOverlay = - void . onEventListOverlay (csCurrentTeam.tsUserListOverlay) userListOverlayKeybindings +onEventUserListOverlay :: TeamId -> Vty.Event -> MH () +onEventUserListOverlay tId = + void . onEventListOverlay tId (csTeam(tId).tsUserListOverlay) (userListOverlayKeybindings tId) -- | The keybindings we want to use while viewing a user list overlay -userListOverlayKeybindings :: KeyConfig -> KeyHandlerMap -userListOverlayKeybindings = mkKeybindings userListOverlayKeyHandlers +userListOverlayKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +userListOverlayKeybindings tId = mkKeybindings (userListOverlayKeyHandlers tId) -userListOverlayKeyHandlers :: [KeyEventHandler] -userListOverlayKeyHandlers = - [ mkKb CancelEvent "Close the user search list" (exitListOverlay (csCurrentTeam.tsUserListOverlay)) - , mkKb SearchSelectUpEvent "Select the previous user" userListSelectUp - , mkKb SearchSelectDownEvent "Select the next user" userListSelectDown - , mkKb PageDownEvent "Page down in the user list" userListPageDown - , mkKb PageUpEvent "Page up in the user list" userListPageUp - , mkKb ActivateListItemEvent "Interact with the selected user" (listOverlayActivateCurrent (csCurrentTeam.tsUserListOverlay)) +userListOverlayKeyHandlers :: TeamId -> [KeyEventHandler] +userListOverlayKeyHandlers tId = + [ mkKb CancelEvent "Close the user search list" (exitListOverlay tId (csTeam(tId).tsUserListOverlay)) + , mkKb SearchSelectUpEvent "Select the previous user" $ userListSelectUp tId + , mkKb SearchSelectDownEvent "Select the next user" $ userListSelectDown tId + , mkKb PageDownEvent "Page down in the user list" $ userListPageDown tId + , mkKb PageUpEvent "Page up in the user list" $ userListPageUp tId + , mkKb ActivateListItemEvent "Interact with the selected user" (listOverlayActivateCurrent tId (csTeam(tId).tsUserListOverlay)) ] diff --git a/src/Matterhorn/Events/Websocket.hs b/src/Matterhorn/Events/Websocket.hs --- a/src/Matterhorn/Events/Websocket.hs +++ b/src/Matterhorn/Events/Websocket.hs @@ -11,7 +11,6 @@ import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T -import Lens.Micro.Platform ( preuse ) import Network.Mattermost.Lenses import Network.Mattermost.Types @@ -58,9 +57,11 @@ when (inMyTeamOrDM (wepTeamId (weData we))) $ do let wasMentioned = maybe False (Set.member myId) $ wepMentions (weData we) addNewPostedMessage $ RecentPost p wasMentioned - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - when (postChannelId p /= cId) $ + mtId <- use csCurrentTeamId + cId <- case mtId of + Nothing -> return Nothing + Just tId -> use (csCurrentChannelId tId) + when (Just (postChannelId p) /= cId) $ showChannelInSidebar (p^.postChannelIdL) False | otherwise -> return () @@ -71,9 +72,9 @@ currTid <- use csCurrentTeamId foreachTeam $ \tId -> do cId <- use (csCurrentChannelId tId) - when (postChannelId p == cId && tId == currTid) $ + when (Just (postChannelId p) == cId && Just tId == currTid) $ updateViewed False - when (postChannelId p /= cId) $ + when (Just (postChannelId p) /= cId) $ showChannelInSidebar (p^.postChannelIdL) False | otherwise -> return () @@ -84,9 +85,9 @@ currTid <- use csCurrentTeamId foreachTeam $ \tId -> do cId <- use (csCurrentChannelId tId) - when (postChannelId p == cId && tId == currTid) $ + when (Just (postChannelId p) == cId && Just tId == currTid) $ updateViewed False - when (postChannelId p /= cId) $ + when (Just (postChannelId p) /= cId) $ showChannelInSidebar (p^.postChannelIdL) False | otherwise -> return () @@ -217,8 +218,9 @@ WMUserUpdated | Just user <- wepUser (weData we) -> do handleUserUpdated user - cid <- use $ csCurrentChannel . ccInfo . cdChannelId - refreshChannelById cid + withCurrentTeam $ \tId -> + withCurrentChannel tId $ \cId _ -> do + refreshChannelById cId | otherwise -> return () -- We deliberately ignore these events: diff --git a/src/Matterhorn/InputHistory.hs b/src/Matterhorn/InputHistory.hs --- a/src/Matterhorn/InputHistory.hs +++ b/src/Matterhorn/InputHistory.hs @@ -16,7 +16,7 @@ import Control.Monad.Trans.Except import qualified Data.HashMap.Strict as HM import qualified Data.Vector as V -import Lens.Micro.Platform ( (.~), (^?), (%~), at, ix, makeLenses ) +import Lens.Micro.Platform ( (.~), (%~), at, ix, makeLenses ) import System.Directory ( createDirectoryIfMissing ) import System.FilePath ( dropFileName ) import qualified System.IO.Strict as S diff --git a/src/Matterhorn/LastRunState.hs b/src/Matterhorn/LastRunState.hs --- a/src/Matterhorn/LastRunState.hs +++ b/src/Matterhorn/LastRunState.hs @@ -35,37 +35,37 @@ -- | Run state of the program. This is saved in a file on program exit and -- | looked up from the file on program startup. -data LastRunState = LastRunState - { _lrsHost :: Hostname -- ^ Host of the server - , _lrsPort :: Port -- ^ Post of the server - , _lrsUserId :: UserId -- ^ ID of the logged-in user - , _lrsSelectedChannelId :: ChannelId -- ^ ID of the last selected channel - } +data LastRunState = + LastRunState { _lrsHost :: Hostname -- ^ Host of the server + , _lrsPort :: Port -- ^ Post of the server + , _lrsUserId :: UserId -- ^ ID of the logged-in user + , _lrsSelectedChannelId :: Maybe ChannelId -- ^ ID of the last selected channel + } instance A.ToJSON LastRunState where - toJSON lrs = A.object [ "host" A..= _lrsHost lrs - , "port" A..= _lrsPort lrs - , "user_id" A..= _lrsUserId lrs - , "sel_channel_id" A..= _lrsSelectedChannelId lrs - ] + toJSON lrs = A.object [ "host" A..= _lrsHost lrs + , "port" A..= _lrsPort lrs + , "user_id" A..= _lrsUserId lrs + , "sel_channel_id" A..= _lrsSelectedChannelId lrs + ] instance A.FromJSON LastRunState where - parseJSON = A.withObject "LastRunState" $ \v -> - LastRunState - <$> v A..: "host" - <*> v A..: "port" - <*> v A..: "user_id" - <*> v A..: "sel_channel_id" + parseJSON = A.withObject "LastRunState" $ \v -> + LastRunState + <$> v A..: "host" + <*> v A..: "port" + <*> v A..: "user_id" + <*> v A..: "sel_channel_id" makeLenses ''LastRunState -toLastRunState :: ChatState -> LastRunState -toLastRunState cs = LastRunState - { _lrsHost = cs^.csResources.crConn.cdHostnameL - , _lrsPort = cs^.csResources.crConn.cdPortL - , _lrsUserId = myUserId cs - , _lrsSelectedChannelId = cs^.csCurrentChannelId(cs^.csCurrentTeamId) - } +toLastRunState :: ChatState -> TeamId -> LastRunState +toLastRunState cs tId = + LastRunState { _lrsHost = cs^.csResources.crConn.cdHostnameL + , _lrsPort = cs^.csResources.crConn.cdPortL + , _lrsUserId = myUserId cs + , _lrsSelectedChannelId = cs^.csCurrentChannelId(tId) + } lastRunStateFileMode :: P.FileMode lastRunStateFileMode = P.unionFileModes P.ownerReadMode P.ownerWriteMode @@ -78,27 +78,33 @@ writeLastRunState cs tId writeLastRunState :: ChatState -> TeamId -> IO () -writeLastRunState cs tId = do - when (cs^.csCurrentChannel.ccInfo.cdType `elem` [Ordinary, Private]) $ do - let runState = toLastRunState cs +writeLastRunState cs tId = + case cs^.csCurrentChannelId(tId) of + Nothing -> return () + Just cId -> case cs^?csChannel(cId) of + Nothing -> return () + Just chan -> + when (chan^.ccInfo.cdType `elem` [Ordinary, Private]) $ do + let runState = toLastRunState cs tId - lastRunStateFile <- lastRunStateFilePath $ unId $ toId tId - createDirectoryIfMissing True $ dropFileName lastRunStateFile - BS.writeFile lastRunStateFile $ LBS.toStrict $ A.encode runState - P.setFileMode lastRunStateFile lastRunStateFileMode + lastRunStateFile <- lastRunStateFilePath $ unId $ toId tId + createDirectoryIfMissing True $ dropFileName lastRunStateFile + BS.writeFile lastRunStateFile $ LBS.toStrict $ A.encode runState + P.setFileMode lastRunStateFile lastRunStateFileMode -- | Reads the last run state from a file given the current team ID. readLastRunState :: TeamId -> IO (Either String LastRunState) readLastRunState tId = runExceptT $ do - contents <- convertIOException $ - lastRunStateFilePath (unId $ toId tId) >>= BS.readFile - case A.eitherDecodeStrict' contents of - Right val -> return val - Left err -> throwE $ "Failed to parse lastRunState file: " ++ err + contents <- convertIOException $ + lastRunStateFilePath (unId $ toId tId) >>= BS.readFile + case A.eitherDecodeStrict' contents of + Right val -> return val + Left err -> throwE $ "Failed to parse lastRunState file: " ++ err -- | Checks if the given last run state is valid for the current server and user. isValidLastRunState :: ChatResources -> User -> LastRunState -> Bool isValidLastRunState cr me rs = - rs^.lrsHost == cr^.crConn.cdHostnameL - && rs^.lrsPort == cr^.crConn.cdPortL - && rs^.lrsUserId == me^.userIdL + and [ rs^.lrsHost == cr^.crConn.cdHostnameL + , rs^.lrsPort == cr^.crConn.cdPortL + , rs^.lrsUserId == me^.userIdL + ] diff --git a/src/Matterhorn/Login.hs b/src/Matterhorn/Login.hs --- a/src/Matterhorn/Login.hs +++ b/src/Matterhorn/Login.hs @@ -48,7 +48,7 @@ -- fails before the timer fires, we just resume normal operation and -- show the login form so the user can intervene. module Matterhorn.Login - ( LoginAttempt(..) + ( LoginSuccess(..) , interactiveGetLoginSession ) where @@ -87,15 +87,15 @@ , ciPassword, ciUsername, ciHostname, ciUrlPath , ciPort, ciType, AuthenticationException(..) , LogManager, LogCategory(..), ioLogWithManager - , ciAccessToken, SemEq(..) + , ciAccessToken, ciOTPToken, SemEq(..) ) - -- | Resource names for the login interface. data Name = Server | Username | Password + | OTPToken | AccessToken deriving (Ord, Eq, Show) @@ -106,9 +106,16 @@ data LoginAttempt = AttemptFailed AuthenticationException -- ^ The attempt failed with the corresponding error. + | MFATokenRequired ConnectionInfo + -- ^ The attempt succeeded, but additional MFA token is required. | AttemptSucceeded ConnectionInfo ConnectionData Session User (Maybe Text) --team -- ^ The attempt succeeded. +-- | The result of a successfull login attempt. +data LoginSuccess = + LoginSuccess ConnectionData Session User (Maybe Text) --team + -- ^ Data associated with the new logged-in session. + -- | The state of the login interface: whether a login attempt is -- currently in progress. data LoginState = @@ -159,6 +166,10 @@ , cpMaxConnCount = 5 } +-- | Error code used when login succeeds, but additional MFA token is required +invalidMFATokenError :: T.Text +invalidMFATokenError = "mfa.validate_token.authenticate.app_error" + -- | Run an IO action and convert various kinds of thrown exceptions -- into a returned AuthenticationException. convertLoginExceptions :: IO a -> IO (Either AuthenticationException a) @@ -197,10 +208,10 @@ do writeBChan respChan $ LoginResult $ AttemptFailed $ OtherAuthError e Right (cd_, mbTeam) -> do let cd = setLogger cd_ - token = connInfo^.ciAccessToken - case T.null token of + accessToken = connInfo^.ciAccessToken + case T.null accessToken of False -> do - let sess = Session cd $ Token $ T.unpack token + let sess = Session cd $ Token $ T.unpack accessToken userResult <- try $ mmGetUser UserMe sess writeBChan respChan $ case userResult of @@ -210,11 +221,15 @@ LoginResult $ AttemptSucceeded connInfo cd sess user mbTeam True -> do let login = Login { username = connInfo^.ciUsername + , otpToken = connInfo^.ciOTPToken , password = connInfo^.ciPassword } result <- convertLoginExceptions $ mmLogin cd login case result of + Left (MattermostServerError (MattermostError {mattermostErrorId = errorId})) | errorId == invalidMFATokenError -> do + doLog $ "Authenticated successfully to " <> connInfo^.ciHostname <> " but MFA token is required" + writeBChan respChan $ LoginResult $ MFATokenRequired connInfo Left e -> do doLog $ "Error authenticating to " <> connInfo^.ciHostname <> ": " <> (T.pack $ show e) writeBChan respChan $ LoginResult $ AttemptFailed e @@ -236,7 +251,11 @@ -- the candidates list is never empty because inits never returns an -- empty list - primary:alternatives = + (primary, alternatives) = case componentList of + (p:as) -> (p, as) + _ -> error $ "BUG: findConnectionData: got failed pattern match on component list: " <> show componentList + + componentList = reverse [ (T.intercalate "/" l, listToMaybe r) | (l,r) <- zip (inits components) (tails components) @@ -307,7 +326,7 @@ -- info provided here is fully populated, an -- initial connection attempt is made without -- first getting the user to hit Enter. - -> IO (Maybe LoginAttempt, Vty) + -> IO (Maybe LoginSuccess, Vty) interactiveGetLoginSession vty mkVty setLogger logMgr initialConfig = do requestChan <- newBChan 10 respChan <- newBChan 10 @@ -326,7 +345,9 @@ (finalSt, finalVty) <- customMainWithVty vty mkVty (Just respChan) app startState - return (finalSt^.lastAttempt, finalVty) + return $ case finalSt^.lastAttempt of + Just (AttemptSucceeded _ cd sess user mbTeam) -> (Just $ LoginSuccess cd sess user mbTeam, finalVty) + _ -> (Nothing, finalVty) -- | Is the specified ConnectionInfo sufficiently populated for us to -- bother attempting to use it to connect? @@ -390,6 +411,8 @@ True -> halt st' False -> continue st' AttemptFailed {} -> continue st' + MFATokenRequired connInfo -> + continue $ st' & loginForm .~ (mkOTPForm connInfo) onEvent st (VtyEvent (EvKey KEnter [])) = do -- Ignore the keypress if we are already attempting a connection, or @@ -423,6 +446,15 @@ label "Access Token:") @@= editPasswordField ciAccessToken AccessToken ] +-- | This form deliberately doesn't provide fields other than the OTP token, +-- because they have already been validated by an initial authenticatin +-- attempty by the time this is used. +mkOTPForm :: ConnectionInfo -> Form ConnectionInfo e Name +mkOTPForm = + let label s w = padBottom (Pad 1) $ + (vLimit 1 $ hLimit 10 $ str s <+> fill ' ') <+> w + in newForm [label "OTP Token:" @@= editOptionalTextField ciOTPToken OTPToken] + serverLens :: Lens' ConnectionInfo (Text, Int, Text, ConnectionType) serverLens f ci = fmap (\(x,y,z,w) -> ci { _ciHostname = x, _ciPort = y, _ciUrlPath = z, _ciType = w}) (f (ci^.ciHostname, ci^.ciPort, ci^.ciUrlPath, ci^.ciType)) @@ -511,6 +543,18 @@ renderTxt ts = txt (T.unlines ts) in editField serverLens Server limit renderServer val renderTxt id +editOptionalTextField :: (Show n, Ord n) => Lens' s (Maybe T.Text) -> n -> s -> FormFieldState s e n +editOptionalTextField stLens n = + let ini Nothing = "" + ini (Just t) = t + val ls = + let stripped = T.strip $ T.concat ls + in if T.null stripped + then Just Nothing + else Just $ Just stripped + renderTxt ts = txt (T.unlines ts) + in editField stLens n (Just 1) ini val renderTxt id + errorAttr :: AttrName errorAttr = "errorMessage" @@ -563,6 +607,7 @@ lastAttemptDisplay :: Maybe LoginAttempt -> Widget Name lastAttemptDisplay Nothing = emptyWidget lastAttemptDisplay (Just (AttemptSucceeded {})) = emptyWidget +lastAttemptDisplay (Just (MFATokenRequired _)) = emptyWidget lastAttemptDisplay (Just (AttemptFailed e)) = hCenter $ hLimit uiWidth $ padTop (Pad 1) $ renderError $ renderText $ diff --git a/src/Matterhorn/Prelude.hs b/src/Matterhorn/Prelude.hs --- a/src/Matterhorn/Prelude.hs +++ b/src/Matterhorn/Prelude.hs @@ -61,7 +61,9 @@ -- common read-only lens operators , (Lens.&) , (Lens.^.) + , (Lens.^?) , Lens.use + , Lens.preuse -- not available in all versions of GHC currently in use #if MIN_VERSION_base(4,10,0) diff --git a/src/Matterhorn/Scripts.hs b/src/Matterhorn/Scripts.hs --- a/src/Matterhorn/Scripts.hs +++ b/src/Matterhorn/Scripts.hs @@ -12,7 +12,7 @@ import qualified Data.Text as T import System.Exit ( ExitCode(..) ) -import Network.Mattermost.Types ( ChannelId ) +import Network.Mattermost.Types ( TeamId, ChannelId ) import Matterhorn.FilePaths ( Script(..), getAllScripts, locateScriptPath ) import Matterhorn.State.Common @@ -20,13 +20,13 @@ import Matterhorn.Types -findAndRunScript :: ChannelId -> Text -> Text -> MH () -findAndRunScript cId scriptName input = do +findAndRunScript :: TeamId -> ChannelId -> Text -> Text -> MH () +findAndRunScript tId cId scriptName input = do fpMb <- liftIO $ locateScriptPath (T.unpack scriptName) outputChan <- use (csResources.crSubprocessLog) case fpMb of ScriptPath scriptPath -> do - doAsyncWith Preempt $ runScript cId outputChan scriptPath input + doAsyncWith Preempt $ runScript tId cId outputChan scriptPath input NonexecScriptPath scriptPath -> do let msg = ("The script `" <> T.pack scriptPath <> "` cannot be " <> "executed. Try running\n" <> @@ -38,8 +38,8 @@ ScriptNotFound -> do mhError $ NoSuchScript scriptName -runScript :: ChannelId -> STM.TChan ProgramOutput -> FilePath -> Text -> IO (Maybe (MH ())) -runScript cId outputChan fp text = do +runScript :: TeamId -> ChannelId -> STM.TChan ProgramOutput -> FilePath -> Text -> IO (Maybe (MH ())) +runScript tId cId outputChan fp text = do outputVar <- newEmptyMVar runLoggedCommand outputChan fp [] (Just $ T.unpack text) (Just outputVar) po <- takeMVar outputVar @@ -47,11 +47,8 @@ ExitSuccess -> do case null $ programStderr po of True -> Just $ do - withChannel cId $ \chan -> do - mode <- case chan^.ccInfo.cdTeamId of - Nothing -> use (csCurrentTeam.tsEditState.cedEditMode) - Just tId -> use (csTeam(tId).tsEditState.cedEditMode) - sendMessage cId mode (T.pack $ programStdout po) [] + mode <- use (csTeam(tId).tsEditState.cedEditMode) + sendMessage cId mode (T.pack $ programStdout po) [] False -> Nothing ExitFailure _ -> Nothing diff --git a/src/Matterhorn/State/Attachments.hs b/src/Matterhorn/State/Attachments.hs --- a/src/Matterhorn/State/Attachments.hs +++ b/src/Matterhorn/State/Attachments.hs @@ -25,6 +25,8 @@ import Lens.Micro.Platform ( (.=), (%=) ) import System.Directory ( doesDirectoryExist, doesFileExist, getDirectoryContents ) +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types validateAttachmentPath :: FilePath -> IO (Maybe FilePath) @@ -40,43 +42,41 @@ defaultAttachmentsPath :: Config -> IO (Maybe FilePath) defaultAttachmentsPath = maybe (return Nothing) validateAttachmentPath . configDefaultAttachmentPath -showAttachmentList :: MH () -showAttachmentList = do - lst <- use (csCurrentTeam.tsEditState.cedAttachmentList) +showAttachmentList :: TeamId -> MH () +showAttachmentList tId = do + lst <- use (csTeam(tId).tsEditState.cedAttachmentList) case length (L.listElements lst) of - 0 -> showAttachmentFileBrowser - _ -> setMode ManageAttachments + 0 -> showAttachmentFileBrowser tId + _ -> setMode tId ManageAttachments -resetAttachmentList :: MH () -resetAttachmentList = do - tId <- use csCurrentTeamId +resetAttachmentList :: TeamId -> MH () +resetAttachmentList tId = do let listName = AttachmentList tId - csCurrentTeam.tsEditState.cedAttachmentList .= L.list listName mempty 1 + csTeam(tId).tsEditState.cedAttachmentList .= L.list listName mempty 1 mh $ vScrollToBeginning $ viewportScroll listName -showAttachmentFileBrowser :: MH () -showAttachmentFileBrowser = do +showAttachmentFileBrowser :: TeamId -> MH () +showAttachmentFileBrowser tId = do config <- use (csResources.crConfiguration) - tId <- use csCurrentTeamId filePath <- liftIO $ defaultAttachmentsPath config browser <- liftIO $ Just <$> FB.newFileBrowser FB.selectNonDirectories (AttachmentFileBrowser tId) filePath - csCurrentTeam.tsEditState.cedFileBrowser .= browser - setMode ManageAttachmentsBrowseFiles + csTeam(tId).tsEditState.cedFileBrowser .= browser + setMode tId ManageAttachmentsBrowseFiles -attachFileByPath :: Text -> MH () -attachFileByPath txtPath = do +attachFileByPath :: TeamId -> Text -> MH () +attachFileByPath tId txtPath = do let strPath = unpack txtPath fileInfo <- liftIO $ FB.getFileInfo strPath strPath case FB.fileInfoFileStatus fileInfo of Left e -> do mhError $ AttachmentException (toException e) - Right _ -> tryAddAttachment [fileInfo] + Right _ -> tryAddAttachment tId [fileInfo] checkPathIsFile :: FB.FileInfo -> MH Bool checkPathIsFile = liftIO . doesFileExist . FB.fileInfoFilePath -tryAddAttachment :: [FB.FileInfo] -> MH () -tryAddAttachment entries = do +tryAddAttachment :: TeamId -> [FB.FileInfo] -> MH () +tryAddAttachment tId entries = do forM_ entries $ \entry -> do isFile <- checkPathIsFile entry if not isFile @@ -84,7 +84,7 @@ "Error attaching file. It either doesn't exist or is a directory, which is not supported.") else do -- Is the entry already present? If so, ignore the selection. - es <- use (csCurrentTeam.tsEditState.cedAttachmentList.L.listElementsL) + es <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listElementsL) let matches = (== FB.fileInfoFilePath entry) . FB.fileInfoFilePath . attachmentDataFileInfo @@ -93,14 +93,14 @@ Nothing -> do tryReadAttachment entry >>= \case Right a -> do - oldIdx <- use (csCurrentTeam.tsEditState.cedAttachmentList.L.listSelectedL) + oldIdx <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listSelectedL) let newIdx = if Vector.null es then Just 0 else oldIdx - csCurrentTeam.tsEditState.cedAttachmentList %= L.listReplace (Vector.snoc es a) newIdx + csTeam(tId).tsEditState.cedAttachmentList %= L.listReplace (Vector.snoc es a) newIdx Left e -> mhError $ AttachmentException e - when (not $ null entries) $ setMode Main + when (not $ null entries) $ setMode tId Main tryReadAttachment :: FB.FileInfo -> MH (Either E.SomeException AttachmentData) tryReadAttachment fi = do diff --git a/src/Matterhorn/State/Autocomplete.hs b/src/Matterhorn/State/Autocomplete.hs --- a/src/Matterhorn/State/Autocomplete.hs +++ b/src/Matterhorn/State/Autocomplete.hs @@ -19,7 +19,7 @@ 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 Lens.Micro.Platform ( (%=), (.=), (.~), _Just ) import qualified Skylighting.Types as Sky import Network.Mattermost.Types (userId, channelId, Command(..), TeamId) @@ -55,13 +55,13 @@ -- should cause an autocompletion UI to appear. If so, initiate a server -- query or local cache lookup to present the completion alternatives -- for the word at the cursor. -checkForAutocompletion :: AutocompleteContext -> MH () -checkForAutocompletion ctx = do - result <- getCompleterForInput ctx +checkForAutocompletion :: TeamId -> AutocompleteContext -> MH () +checkForAutocompletion tId ctx = do + result <- getCompleterForInput tId ctx case result of - Nothing -> resetAutocomplete + Nothing -> resetAutocomplete tId Just (ty, runUpdater, searchString) -> do - prevResult <- use (csCurrentTeam.tsEditState.cedAutocomplete) + prevResult <- use (csTeam(tId).tsEditState.cedAutocomplete) -- We should update the completion state if EITHER: -- -- 1) The type changed @@ -74,13 +74,14 @@ (maybe True ((== ty) . _acType) prevResult)) || (maybe False ((/= ty) . _acType) prevResult) when shouldUpdate $ do - csCurrentTeam.tsEditState.cedAutocompletePending .= Just searchString + csTeam(tId).tsEditState.cedAutocompletePending .= Just searchString runUpdater ty ctx searchString -getCompleterForInput :: AutocompleteContext +getCompleterForInput :: TeamId + -> AutocompleteContext -> MH (Maybe (AutocompletionType, AutocompletionType -> AutocompleteContext -> Text -> MH (), Text)) -getCompleterForInput ctx = do - z <- use (csCurrentTeam.tsEditState.cedEditor.editContentsL) +getCompleterForInput tId ctx = do + z <- use (csTeam(tId).tsEditState.cedEditor.editContentsL) let col = snd $ Z.cursorPosition z curLine = Z.currentLine z @@ -88,34 +89,32 @@ return $ case wordAtColumn col curLine of Just (startCol, w) | userSigil `T.isPrefixOf` w -> - Just (ACUsers, doUserAutoCompletion, T.tail w) + Just (ACUsers, doUserAutoCompletion tId, T.tail w) | normalChannelSigil `T.isPrefixOf` w -> - Just (ACChannels, doChannelAutoCompletion, T.tail w) + Just (ACChannels, doChannelAutoCompletion tId, T.tail w) | ":" `T.isPrefixOf` w && autocompleteManual ctx -> - Just (ACEmoji, doEmojiAutoCompletion, T.tail w) + Just (ACEmoji, doEmojiAutoCompletion tId, T.tail w) | "```" `T.isPrefixOf` w -> - Just (ACCodeBlockLanguage, doSyntaxAutoCompletion, T.drop 3 w) + Just (ACCodeBlockLanguage, doSyntaxAutoCompletion tId, T.drop 3 w) | "/" `T.isPrefixOf` w && startCol == 0 -> - Just (ACCommands, doCommandAutoCompletion, T.tail w) + Just (ACCommands, doCommandAutoCompletion tId, T.tail w) _ -> Nothing -- Completion implementations -doEmojiAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () -doEmojiAutoCompletion ty ctx searchString = do +doEmojiAutoCompletion :: TeamId -> AutocompletionType -> AutocompleteContext -> Text -> MH () +doEmojiAutoCompletion tId ty ctx searchString = do session <- getSession em <- use (csResources.crEmoji) - tId <- use csCurrentTeamId withCachedAutocompleteResults tId ctx ty searchString $ doAsyncWith Preempt $ do results <- getMatchingEmoji session em searchString let alts = EmojiCompletion <$> results return $ Just $ setCompletionAlternatives tId ctx searchString alts ty -doSyntaxAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () -doSyntaxAutoCompletion ty ctx searchString = do +doSyntaxAutoCompletion :: TeamId -> AutocompletionType -> AutocompleteContext -> Text -> MH () +doSyntaxAutoCompletion tId ty ctx searchString = do mapping <- use (csResources.crSyntaxMap) - tId <- use csCurrentTeamId let allNames = Sky.sShortname <$> M.elems mapping (prefixed, notPrefixed) = partition isPrefixed $ filter match allNames match = (((T.toLower searchString) `T.isInfixOf`) . T.toLower) @@ -170,10 +169,9 @@ isDeletedCommand :: Command -> Bool isDeletedCommand cmd = commandDeleteAt cmd > commandCreateAt cmd -doCommandAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () -doCommandAutoCompletion ty ctx searchString = do +doCommandAutoCompletion :: TeamId -> AutocompletionType -> AutocompleteContext -> Text -> MH () +doCommandAutoCompletion myTid ty ctx searchString = do session <- getSession - myTid <- use csCurrentTeamId mCache <- preuse (csTeam(myTid).tsEditState.cedAutocomplete._Just.acCachedResponses) mActiveTy <- preuse (csTeam(myTid).tsEditState.cedAutocomplete._Just.acType) @@ -257,36 +255,33 @@ else GT compareCommandAlts _ _ _ = LT -doUserAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () -doUserAutoCompletion ty ctx searchString = do +doUserAutoCompletion :: TeamId -> AutocompletionType -> AutocompleteContext -> Text -> MH () +doUserAutoCompletion tId ty ctx searchString = do session <- getSession - tId <- use csCurrentTeamId myUid <- gets myUserId - cId <- use (csCurrentChannelId(tId)) - - withCachedAutocompleteResults tId ctx ty searchString $ - doAsyncWith Preempt $ do - ac <- MM.mmAutocompleteUsers (Just tId) (Just cId) searchString session + withCurrentChannel tId $ \cId _ -> do + withCachedAutocompleteResults tId ctx ty searchString $ + doAsyncWith Preempt $ do + ac <- MM.mmAutocompleteUsers (Just tId) (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) + let active = Seq.filter (\u -> userId u /= myUid && (not $ userDeleted u)) + alts = F.toList $ + ((\u -> UserCompletion u True) <$> (active $ MM.userAutocompleteUsers ac)) <> + (maybe mempty (fmap (\u -> UserCompletion u False) . active) $ + MM.userAutocompleteOutOfChannel ac) - specials = [ MentionAll - , MentionChannel - ] - extras = [ SpecialMention m | m <- specials - , (T.toLower searchString) `T.isPrefixOf` specialMentionName m - ] + specials = [ MentionAll + , MentionChannel + ] + extras = [ SpecialMention m | m <- specials + , (T.toLower searchString) `T.isPrefixOf` specialMentionName m + ] - return $ Just $ setCompletionAlternatives tId ctx searchString (alts <> extras) ty + return $ Just $ setCompletionAlternatives tId ctx searchString (alts <> extras) ty -doChannelAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () -doChannelAutoCompletion ty ctx searchString = do +doChannelAutoCompletion :: TeamId -> AutocompletionType -> AutocompleteContext -> Text -> MH () +doChannelAutoCompletion tId ty ctx searchString = do session <- getSession - tId <- use csCurrentTeamId cs <- use csChannels withCachedAutocompleteResults tId ctx ty searchString $ do @@ -362,7 +357,7 @@ mh $ vScrollToBeginning $ viewportScroll $ CompletionList tId when (autocompleteFirstMatch ctx) $ - tabComplete Forwards + tabComplete tId Forwards _ -> -- Do not update the state if this result does not -- correspond to the search string we used most recently. diff --git a/src/Matterhorn/State/ChannelList.hs b/src/Matterhorn/State/ChannelList.hs --- a/src/Matterhorn/State/ChannelList.hs +++ b/src/Matterhorn/State/ChannelList.hs @@ -13,6 +13,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Sequence as Seq import Data.Time.Clock ( getCurrentTime ) +import Data.Maybe ( fromJust ) import qualified Graphics.Vty as Vty import Lens.Micro.Platform @@ -44,9 +45,10 @@ -- Schedule the current team's sidebar for user status updates at -- the end of this MH action. This is okay because all team sidebars -- should include the same set of DM channels. - z <- use (csCurrentTeam.tsFocus) - myId <- gets myUserId - scheduleUserStatusFetches $ myId : userIdsFromZipper z + withCurrentTeam $ \tId -> do + z <- use (csTeam(tId).tsFocus) + myId <- gets myUserId + scheduleUserStatusFetches $ myId : userIdsFromZipper z updateWindowTitle @@ -78,12 +80,14 @@ -- Update the zipper cs <- use csChannels + sorting <- use (csTeam(tId).tsChannelListSorting) us <- getUsers prefs <- use (csResources.crUserPreferences) + hidden <- use csHiddenChannelGroups now <- liftIO getCurrentTime config <- use (csResources.crConfiguration) - let zl = mkChannelZipperList now config tId cconfig prefs cs us + let zl = mkChannelZipperList sorting now config tId cconfig prefs hidden cs us compareEntries mOld new = (channelListEntryChannelId <$> mOld) == Just (channelListEntryChannelId new) csTeam(tId).tsFocus %= Z.updateListBy compareEntries zl @@ -93,7 +97,7 @@ -- that it gets loaded. newCid <- use (csCurrentChannelId tId) when (newCid /= oldCid) $ - fetchVisibleIfNeeded + fetchVisibleIfNeeded tId toggleChannelListVisibility :: MH () toggleChannelListVisibility = do @@ -127,24 +131,20 @@ -- displayable, and the UI should always prefer to SATISFY -- the user's latest request over any pending/background -- task. - csCurrentTeam.tsPendingChannelChange .= Nothing - now <- liftIO getCurrentTime csChannel(cId).ccInfo.cdSidebarShowOverride .= Just now updateSidebar (ch^.ccInfo.cdTeamId) - curTid <- use csCurrentTeamId - let tId = fromMaybe curTid (ch^.ccInfo.cdTeamId) - case ch^.ccInfo.cdType of Direct -> do - let Just uId = ch^.ccInfo.cdDMUserId + let uId = fromJust $ ch^.ccInfo.cdDMUserId case dmChannelShowPreference prefs uId of Just False -> do let pref = showDirectChannelPref (me^.userIdL) uId True when setPending $ - csCurrentTeam.tsPendingChannelChange .= - Just (ChangeByChannelId tId (ch^.ccInfo.cdChannelId) Nothing) + withCurrentTeam $ \tId -> + csTeam(tId).tsPendingChannelChange .= + Just (ChangeByChannelId tId (ch^.ccInfo.cdChannelId) Nothing) doAsyncWith Preempt $ do MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session return Nothing @@ -155,8 +155,9 @@ Just False -> do let pref = showGroupChannelPref cId (me^.userIdL) when setPending $ - csCurrentTeam.tsPendingChannelChange .= - Just (ChangeByChannelId tId (ch^.ccInfo.cdChannelId) Nothing) + withCurrentTeam $ \tId -> + csTeam(tId).tsPendingChannelChange .= + Just (ChangeByChannelId tId (ch^.ccInfo.cdChannelId) Nothing) doAsyncWith Preempt $ do MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session return Nothing diff --git a/src/Matterhorn/State/ChannelListOverlay.hs b/src/Matterhorn/State/ChannelListOverlay.hs --- a/src/Matterhorn/State/ChannelListOverlay.hs +++ b/src/Matterhorn/State/ChannelListOverlay.hs @@ -26,16 +26,15 @@ import Matterhorn.Types -enterChannelListOverlayMode :: MH () -enterChannelListOverlayMode = do - myTId <- use csCurrentTeamId +enterChannelListOverlayMode :: TeamId -> MH () +enterChannelListOverlayMode tId = do myChannels <- use (csChannels.to (filteredChannelIds (const True))) - enterListOverlayMode (csTeam(myTId).tsChannelListOverlay) ChannelListOverlay - AllChannels enterHandler (fetchResults myTId myChannels) + enterListOverlayMode tId (csTeam(tId).tsChannelListOverlay) ChannelListOverlay + AllChannels (enterHandler tId) (fetchResults tId myChannels) -enterHandler :: Channel -> MH Bool -enterHandler chan = do - joinChannel (getId chan) +enterHandler :: TeamId -> Channel -> MH Bool +enterHandler tId chan = do + joinChannel tId (getId chan) return True fetchResults :: TeamId @@ -57,28 +56,28 @@ return sortedChans -- | Move the selection up in the channel list overlay by one channel. -channelListSelectUp :: MH () -channelListSelectUp = channelListMove L.listMoveUp +channelListSelectUp :: TeamId -> MH () +channelListSelectUp tId = channelListMove tId L.listMoveUp -- | Move the selection down in the channel list overlay by one channel. -channelListSelectDown :: MH () -channelListSelectDown = channelListMove L.listMoveDown +channelListSelectDown :: TeamId -> MH () +channelListSelectDown tId = channelListMove tId L.listMoveDown -- | Move the selection up in the channel list overlay by a page of channels -- (channelListPageSize). -channelListPageUp :: MH () -channelListPageUp = channelListMove (L.listMoveBy (-1 * channelListPageSize)) +channelListPageUp :: TeamId -> MH () +channelListPageUp tId = channelListMove tId (L.listMoveBy (-1 * channelListPageSize)) -- | Move the selection down in the channel list overlay by a page of channels -- (channelListPageSize). -channelListPageDown :: MH () -channelListPageDown = channelListMove (L.listMoveBy channelListPageSize) +channelListPageDown :: TeamId -> MH () +channelListPageDown tId = channelListMove tId (L.listMoveBy channelListPageSize) -- | Transform the channel list results in some way, e.g. by moving the -- cursor, and then check to see whether the modification warrants a -- prefetch of more search results. -channelListMove :: (L.List Name Channel -> L.List Name Channel) -> MH () -channelListMove = listOverlayMove (csCurrentTeam.tsChannelListOverlay) +channelListMove :: TeamId -> (L.List Name Channel -> L.List Name Channel) -> MH () +channelListMove tId = listOverlayMove (csTeam(tId).tsChannelListOverlay) -- | The number of channels in a "page" for cursor movement purposes. channelListPageSize :: Int diff --git a/src/Matterhorn/State/ChannelSelect.hs b/src/Matterhorn/State/ChannelSelect.hs --- a/src/Matterhorn/State/ChannelSelect.hs +++ b/src/Matterhorn/State/ChannelSelect.hs @@ -21,32 +21,31 @@ import Matterhorn.Types import qualified Matterhorn.Zipper as Z -beginChannelSelect :: MH () -beginChannelSelect = do - setMode ChannelSelect - tId <- use csCurrentTeamId - csCurrentTeam.tsChannelSelectState .= emptyChannelSelectState tId - updateChannelSelectMatches +beginChannelSelect :: MM.TeamId -> MH () +beginChannelSelect tId = do + setMode tId ChannelSelect + csTeam(tId).tsChannelSelectState .= emptyChannelSelectState tId + updateChannelSelectMatches tId -- Preserve the current channel selection when initializing channel -- selection mode - zipper <- use (csCurrentTeam.tsFocus) + zipper <- use (csTeam(tId).tsFocus) let isCurrentFocus m = Just (matchEntry m) == Z.focus zipper - csCurrentTeam.tsChannelSelectState.channelSelectMatches %= Z.findRight isCurrentFocus + csTeam(tId).tsChannelSelectState.channelSelectMatches %= Z.findRight isCurrentFocus -- Select the next match in channel selection mode. -channelSelectNext :: MH () -channelSelectNext = updateSelectedMatch Z.right +channelSelectNext :: MM.TeamId -> MH () +channelSelectNext tId = updateSelectedMatch tId Z.right -- Select the previous match in channel selection mode. -channelSelectPrevious :: MH () -channelSelectPrevious = updateSelectedMatch Z.left +channelSelectPrevious :: MM.TeamId -> MH () +channelSelectPrevious tId = updateSelectedMatch tId Z.left -updateChannelSelectMatches :: MH () -updateChannelSelectMatches = do +updateChannelSelectMatches :: MM.TeamId -> MH () +updateChannelSelectMatches tId = do st <- use id - input <- use (csCurrentTeam.tsChannelSelectState.channelSelectInput) + input <- use (csTeam(tId).tsChannelSelectState.channelSelectInput) cconfig <- use csClientConfig prefs <- use (csResources.crUserPreferences) @@ -86,8 +85,8 @@ preserveFocus Nothing _ = False preserveFocus (Just m) m2 = matchEntry m == matchEntry m2 - csCurrentTeam.tsChannelSelectState.channelSelectMatches %= - (Z.updateListBy preserveFocus $ Z.toList $ Z.maybeMapZipper matches (st^.csCurrentTeam.tsFocus)) + csTeam(tId).tsChannelSelectState.channelSelectMatches %= + (Z.updateListBy preserveFocus $ Z.toList $ Z.maybeMapZipper matches (st^.csTeam(tId).tsFocus)) applySelectPattern :: ChannelSelectPattern -> ChannelListEntry -> Text -> Maybe ChannelSelectMatch applySelectPattern CSPAny entry chanName = do @@ -154,7 +153,8 @@ -- Update the channel selection mode match cursor. The argument function -- determines how to navigate to the next item. -updateSelectedMatch :: (Z.Zipper ChannelListGroup ChannelSelectMatch -> Z.Zipper ChannelListGroup ChannelSelectMatch) +updateSelectedMatch :: MM.TeamId + -> (Z.Zipper ChannelListGroup ChannelSelectMatch -> Z.Zipper ChannelListGroup ChannelSelectMatch) -> MH () -updateSelectedMatch nextItem = - csCurrentTeam.tsChannelSelectState.channelSelectMatches %= nextItem +updateSelectedMatch tId nextItem = + csTeam(tId).tsChannelSelectState.channelSelectMatches %= nextItem diff --git a/src/Matterhorn/State/ChannelTopicWindow.hs b/src/Matterhorn/State/ChannelTopicWindow.hs --- a/src/Matterhorn/State/ChannelTopicWindow.hs +++ b/src/Matterhorn/State/ChannelTopicWindow.hs @@ -8,13 +8,17 @@ import Lens.Micro.Platform ( (.=) ) +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types import Matterhorn.State.Channels ( getCurrentChannelTopic ) -openChannelTopicWindow :: MH () -openChannelTopicWindow = do - t <- getCurrentChannelTopic - tId <- use csCurrentTeamId - csCurrentTeam.tsChannelTopicDialog .= newChannelTopicDialog tId t - setMode ChannelTopicWindow +openChannelTopicWindow :: TeamId -> MH () +openChannelTopicWindow tId = do + t <- getCurrentChannelTopic tId + case t of + Nothing -> return () + Just topic -> do + csTeam(tId).tsChannelTopicDialog .= newChannelTopicDialog tId topic + setMode tId ChannelTopicWindow diff --git a/src/Matterhorn/State/Channels.hs b/src/Matterhorn/State/Channels.hs --- a/src/Matterhorn/State/Channels.hs +++ b/src/Matterhorn/State/Channels.hs @@ -47,14 +47,20 @@ , updateChannelNotifyProps , renameChannelUrl , toggleChannelFavoriteStatus + , toggleChannelListGroupVisibility + , toggleCurrentChannelChannelListGroup + , toggleCurrentChannelChannelListGroupByName + , cycleChannelListSortingMode ) where import Prelude () import Matterhorn.Prelude -import Brick.Main ( viewportScroll, vScrollToBeginning - , invalidateCache, invalidateCacheEntry ) +import Brick.Main ( invalidateCache, invalidateCacheEntry + , makeVisible, vScrollToBeginning + , viewportScroll + ) import Brick.Widgets.Edit ( applyEdit, getEditContents, editContentsL ) import Control.Concurrent.Async ( runConcurrently, Concurrently(..) ) import Control.Exception ( SomeException, try ) @@ -89,9 +95,10 @@ updateViewed :: Bool -> MH () updateViewed updatePrev = do - csCurrentChannel.ccInfo.cdMentionCount .= 0 - tId <- use csCurrentTeamId - updateViewedChan updatePrev =<< use (csCurrentChannelId tId) + withCurrentTeam $ \tId -> do + withCurrentChannel tId $ \cId _ -> do + csChannel(cId).ccInfo.cdMentionCount .= 0 + updateViewedChan updatePrev cId -- | When a new channel has been selected for viewing, this will -- notify the server of the change, and also update the local channel @@ -112,7 +119,11 @@ then do case chan^.ccInfo.cdTeamId of Just tId -> use (csTeam(tId).tsRecentChannel) - Nothing -> use (csCurrentTeam.tsRecentChannel) + Nothing -> do + mtId <- use csCurrentTeamId + case mtId of + Nothing -> return Nothing + Just tId -> use (csTeam(tId).tsRecentChannel) else return Nothing doAsyncChannelMM Preempt cId (\s c -> MM.mmViewChannel UserMe c pId s) @@ -148,7 +159,7 @@ case chan^.ccInfo.cdType of Direct -> do let pref = showDirectChannelPref (me^.userIdL) uId False - Just uId = chan^.ccInfo.cdDMUserId + uId = fromJust $ chan^.ccInfo.cdDMUserId csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing doAsyncWith Preempt $ do MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session @@ -308,7 +319,13 @@ me <- gets myUser mChan <- preuse (csChannel(getId nc)) case mChan of - Just _ -> when switch $ setFocus (getId nc) + Just ch -> do + mtId <- case ch^.ccInfo.cdTeamId of + Nothing -> use csCurrentTeamId + Just i -> return $ Just i + when switch $ case mtId of + Nothing -> return () + Just tId -> setFocus tId (getId nc) Nothing -> do -- Create a new ClientChannel structure cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$> @@ -366,21 +383,28 @@ -- possible to do so. updateSidebar (cChannel^.ccInfo.cdTeamId) + mtId <- case cChannel^.ccInfo.cdTeamId of + Nothing -> use csCurrentTeamId + Just i -> return $ Just i + -- Finally, set our focus to the newly created -- channel if the caller requested a change of -- channel. Also consider the last join request -- state field in case this is an asynchronous -- channel addition triggered by a /join. - pending1 <- checkPendingChannelChange (getId nc) - pending2 <- case cChannel^.ccInfo.cdDMUserId of - Nothing -> return False - Just uId -> checkPendingChannelChangeByUserId uId + case mtId of + Nothing -> return () + Just tId -> do + pending1 <- checkPendingChannelChange tId (getId nc) + pending2 <- case cChannel^.ccInfo.cdDMUserId of + Nothing -> return False + Just uId -> checkPendingChannelChangeByUserId tId uId - when (switch || isJust pending1 || pending2) $ do - setFocus (getId nc) - case pending1 of - Just (Just act) -> act - _ -> return () + when (switch || isJust pending1 || pending2) $ do + setFocus tId (getId nc) + case pending1 of + Just (Just act) -> act + _ -> return () -- | Check to see whether the specified channel has been queued up to -- be switched to. Note that this condition is only cleared by the @@ -391,10 +415,9 @@ -- Returns Just if the specified channel has a pending switch. The -- result is an optional action to invoke after changing to the -- specified channel. -checkPendingChannelChange :: ChannelId -> MH (Maybe (Maybe (MH ()))) -checkPendingChannelChange cId = do - ch <- use (csCurrentTeam.tsPendingChannelChange) - curTid <- use csCurrentTeamId +checkPendingChannelChange :: TeamId -> ChannelId -> MH (Maybe (Maybe (MH ()))) +checkPendingChannelChange curTid cId = do + ch <- use (csTeam(curTid).tsPendingChannelChange) return $ case ch of Just (ChangeByChannelId tId i act) -> if i == cId && curTid == tId then Just act else Nothing @@ -409,9 +432,9 @@ -- Returns Just if the specified channel has a pending switch. The -- result is an optional action to invoke after changing to the -- specified channel. -checkPendingChannelChangeByUserId :: UserId -> MH Bool -checkPendingChannelChangeByUserId uId = do - ch <- use (csCurrentTeam.tsPendingChannelChange) +checkPendingChannelChangeByUserId :: TeamId -> UserId -> MH Bool +checkPendingChannelChangeByUserId tId uId = do + ch <- use (csTeam(tId).tsPendingChannelChange) return $ case ch of Just (ChangeByUserId i) -> i == uId @@ -427,19 +450,20 @@ withChannel cid $ \chan -> updateSidebar (chan^.ccInfo.cdTeamId) -setFocus :: ChannelId -> MH () -setFocus cId = do +setFocus :: TeamId -> ChannelId -> MH () +setFocus tId cId = do showChannelInSidebar cId True - setFocusWith True (Z.findRight ((== cId) . channelListEntryChannelId)) (return ()) + setFocusWith tId True (Z.findRight ((== cId) . channelListEntryChannelId)) (return ()) (return ()) -setFocusWith :: Bool +setFocusWith :: TeamId + -> Bool -> (Zipper ChannelListGroup ChannelListEntry -> Zipper ChannelListGroup ChannelListEntry) -> MH () -> MH () -setFocusWith updatePrev f onNoChange = do - tId <- use csCurrentTeamId - oldZipper <- use (csCurrentTeam.tsFocus) + -> MH () +setFocusWith tId updatePrev f onChange onNoChange = do + oldZipper <- use (csTeam(tId).tsFocus) let newZipper = f oldZipper newFocus = Z.focus newZipper oldFocus = Z.focus oldZipper @@ -449,89 +473,84 @@ if newFocus /= oldFocus then do mh $ invalidateCacheEntry $ ChannelSidebar tId - resetAutocomplete - preChangeChannelCommon - csCurrentTeam.tsFocus .= newZipper + resetAutocomplete tId + preChangeChannelCommon tId + csTeam(tId).tsFocus .= newZipper now <- liftIO getCurrentTime - newCid <- use (csCurrentChannelId tId) - csChannel(newCid).ccInfo.cdSidebarShowOverride .= Just now + mNewCid <- use (csCurrentChannelId tId) + case mNewCid of + Nothing -> return () + Just newCid -> do + csChannel(newCid).ccInfo.cdSidebarShowOverride .= Just now updateViewed updatePrev - postChangeChannelCommon - else onNoChange - -postChangeChannelCommon :: MH () -postChangeChannelCommon = do - resetEditorState - updateChannelListScroll - loadLastEdit - fetchVisibleIfNeeded + postChangeChannelCommon tId -loadLastEdit :: MH () -loadLastEdit = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) + case newFocus of + Nothing -> return () + Just _ -> mh $ makeVisible $ SelectedChannelListEntry tId - oldEphemeral <- preuse (csChannel(cId).ccEditState) - case oldEphemeral of - Nothing -> return () - Just e -> csCurrentTeam.tsEditState.cedEphemeral .= e + onChange + else onNoChange - loadLastChannelInput +postChangeChannelCommon :: TeamId -> MH () +postChangeChannelCommon tId = do + resetEditorState tId + loadLastEdit tId + fetchVisibleIfNeeded tId -loadLastChannelInput :: MH () -loadLastChannelInput = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - inputHistoryPos <- use (csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition) - case inputHistoryPos of - Just i -> loadHistoryEntryToEditor cId i - Nothing -> do - (lastEdit, lastEditMode) <- use (csCurrentTeam.tsEditState.cedEphemeral.eesLastInput) - csCurrentTeam.tsEditState.cedEditor %= (applyEdit $ insertMany lastEdit . clearZipper) - csCurrentTeam.tsEditState.cedEditMode .= lastEditMode +loadLastEdit :: TeamId -> MH () +loadLastEdit tId = do + withCurrentChannel tId $ \cId _ -> do + oldEphemeral <- preuse (csChannel(cId).ccEditState) + case oldEphemeral of + Nothing -> return () + Just e -> csTeam(tId).tsEditState.cedEphemeral .= e -updateChannelListScroll :: MH () -updateChannelListScroll = do - tId <- use csCurrentTeamId - mh $ vScrollToBeginning (viewportScroll $ ChannelList tId) + loadLastChannelInput tId -preChangeChannelCommon :: MH () -preChangeChannelCommon = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - csCurrentTeam.tsRecentChannel .= Just cId - saveCurrentEdit +loadLastChannelInput :: TeamId -> MH () +loadLastChannelInput tId = do + withCurrentChannel tId $ \cId _ -> do + inputHistoryPos <- use (csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition) + case inputHistoryPos of + Just i -> loadHistoryEntryToEditor tId cId i + Nothing -> do + (lastEdit, lastEditMode) <- use (csTeam(tId).tsEditState.cedEphemeral.eesLastInput) + csTeam(tId).tsEditState.cedEditor %= (applyEdit $ insertMany lastEdit . clearZipper) + csTeam(tId).tsEditState.cedEditMode .= lastEditMode -resetEditorState :: MH () -resetEditorState = do - csCurrentTeam.tsEditState.cedEditMode .= NewPost - clearEditor +preChangeChannelCommon :: TeamId -> MH () +preChangeChannelCommon tId = do + withCurrentChannel tId $ \cId _ -> do + csTeam(tId).tsRecentChannel .= Just cId + saveCurrentEdit tId -clearEditor :: MH () -clearEditor = csCurrentTeam.tsEditState.cedEditor %= applyEdit clearZipper +resetEditorState :: TeamId -> MH () +resetEditorState tId = do + csTeam(tId).tsEditState.cedEditMode .= NewPost + csTeam(tId).tsEditState.cedEditor %= applyEdit clearZipper -saveCurrentEdit :: MH () -saveCurrentEdit = do - saveCurrentChannelInput +saveCurrentEdit :: TeamId -> MH () +saveCurrentEdit tId = do + withCurrentChannel tId $ \cId _ -> do + saveCurrentChannelInput tId - oldEphemeral <- use (csCurrentTeam.tsEditState.cedEphemeral) - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - csChannel(cId).ccEditState .= oldEphemeral + oldEphemeral <- use (csTeam(tId).tsEditState.cedEphemeral) + csChannel(cId).ccEditState .= oldEphemeral -saveCurrentChannelInput :: MH () -saveCurrentChannelInput = do - cmdLine <- use (csCurrentTeam.tsEditState.cedEditor) - mode <- use (csCurrentTeam.tsEditState.cedEditMode) +saveCurrentChannelInput :: TeamId -> MH () +saveCurrentChannelInput tId = do + cmdLine <- use (csTeam(tId).tsEditState.cedEditor) + mode <- use (csTeam(tId).tsEditState.cedEditMode) -- Only save the editor contents if the user is not navigating the -- history. - inputHistoryPos <- use (csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition) + inputHistoryPos <- use (csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition) when (isNothing inputHistoryPos) $ - csCurrentTeam.tsEditState.cedEphemeral.eesLastInput .= + csTeam(tId).tsEditState.cedEphemeral.eesLastInput .= (T.intercalate "\n" $ getEditContents $ cmdLine, mode) applyPreferenceChange :: Preference -> MH () @@ -559,15 +578,16 @@ -- 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 + let cId = fromJust $ getDmChannelFor (directChannelShowUserId d) cs case directChannelShowValue d of True -> do - pending <- checkPendingChannelChange cId - case pending of - Just mAct -> do - setFocus cId - fromMaybe (return ()) mAct - Nothing -> return () + withCurrentTeam $ \tId -> do + pending <- checkPendingChannelChange tId cId + case pending of + Just mAct -> do + setFocus tId cId + fromMaybe (return ()) mAct + Nothing -> return () False -> do csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing @@ -581,12 +601,13 @@ let cId = groupChannelId g case groupChannelShow g of True -> do - pending <- checkPendingChannelChange cId - case pending of - Just mAct -> do - setFocus cId - fromMaybe (return ()) mAct - Nothing -> return () + withCurrentTeam $ \tId -> do + pending <- checkPendingChannelChange tId cId + case pending of + Just mAct -> do + setFocus tId cId + fromMaybe (return ()) mAct + Nothing -> return () False -> do csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing @@ -600,12 +621,13 @@ let cId = favoriteChannelId f case favoriteChannelShow f of True -> do - pending <- checkPendingChannelChange cId - case pending of - Just mAct -> do - setFocus cId - fromMaybe (return ()) mAct - Nothing -> return () + withCurrentTeam $ \tId -> do + pending <- checkPendingChannelChange tId cId + case pending of + Just mAct -> do + setFocus tId cId + fromMaybe (return ()) mAct + Nothing -> return () False -> do csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing | otherwise -> return () @@ -627,7 +649,7 @@ Nothing -> return () Just tId -> do origFocus <- use (csCurrentChannelId tId) - when (origFocus == cId) nextChannelSkipPrevView + when (origFocus == Just cId) (nextChannelSkipPrevView tId) -- Update input history csInputHistory %= removeChannelHistory cId @@ -644,72 +666,83 @@ updateSidebar $ chan^.ccInfo.cdTeamId -nextChannel :: MH () -nextChannel = do - resetReturnChannel - setFocusWith True Z.right (return ()) +nextChannel :: TeamId -> MH () +nextChannel tId = do + resetReturnChannel tId + let checkForFirst = do + z <- use (csTeam(tId).tsFocus) + case Z.focus z of + Nothing -> + return () + Just entry -> do + -- If the newly-selected channel is the first + -- visible entry in the channel list, we also want + -- to scroll the channel list up far enough to show + -- the topmost section header. + when (entry == (head $ concat $ snd <$> Z.toList z)) $ do + mh $ vScrollToBeginning $ viewportScroll (ChannelList tId) + setFocusWith tId True Z.right checkForFirst (return ()) + -- | This is almost never what you want; we use this when we delete a -- channel and we don't want to update the deleted channel's view time. -nextChannelSkipPrevView :: MH () -nextChannelSkipPrevView = setFocusWith False Z.right (return ()) +nextChannelSkipPrevView :: TeamId -> MH () +nextChannelSkipPrevView tId = setFocusWith tId False Z.right (return ()) (return ()) -prevChannel :: MH () -prevChannel = do - resetReturnChannel - setFocusWith True Z.left (return ()) +prevChannel :: TeamId -> MH () +prevChannel tId = do + resetReturnChannel tId + setFocusWith tId True Z.left (return ()) (return ()) -recentChannel :: MH () -recentChannel = do - recent <- use (csCurrentTeam.tsRecentChannel) +recentChannel :: TeamId -> MH () +recentChannel tId = do + recent <- use (csTeam(tId).tsRecentChannel) case recent of Nothing -> return () Just cId -> do - ret <- use (csCurrentTeam.tsReturnChannel) - when (ret == Just cId) resetReturnChannel - setFocus cId + ret <- use (csTeam(tId).tsReturnChannel) + when (ret == Just cId) (resetReturnChannel tId) + setFocus tId cId -resetReturnChannel :: MH () -resetReturnChannel = do - val <- use (csCurrentTeam.tsReturnChannel) +resetReturnChannel :: TeamId -> MH () +resetReturnChannel tId = do + val <- use (csTeam(tId).tsReturnChannel) case val of Nothing -> return () Just _ -> do - tId <- use csCurrentTeamId mh $ invalidateCacheEntry $ ChannelSidebar tId - csCurrentTeam.tsReturnChannel .= Nothing + csTeam(tId).tsReturnChannel .= Nothing -gotoReturnChannel :: MH () -gotoReturnChannel = do - ret <- use (csCurrentTeam.tsReturnChannel) +gotoReturnChannel :: TeamId -> MH () +gotoReturnChannel tId = do + ret <- use (csTeam(tId).tsReturnChannel) case ret of Nothing -> return () Just cId -> do - resetReturnChannel - setFocus cId + resetReturnChannel tId + setFocus tId cId -setReturnChannel :: MH () -setReturnChannel = do - ret <- use (csCurrentTeam.tsReturnChannel) +setReturnChannel :: TeamId -> MH () +setReturnChannel tId = do + ret <- use (csTeam(tId).tsReturnChannel) case ret of Nothing -> do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - csCurrentTeam.tsReturnChannel .= Just cId - mh $ invalidateCacheEntry $ ChannelSidebar tId + withCurrentChannel tId $ \cId _ -> do + csTeam(tId).tsReturnChannel .= Just cId + mh $ invalidateCacheEntry $ ChannelSidebar tId Just _ -> return () -nextUnreadChannel :: MH () -nextUnreadChannel = do +nextUnreadChannel :: TeamId -> MH () +nextUnreadChannel tId = do st <- use id - setReturnChannel - setFocusWith True (getNextUnreadChannel st) gotoReturnChannel + setReturnChannel tId + setFocusWith tId True (getNextUnreadChannel st tId) (return ()) (gotoReturnChannel tId) -nextUnreadUserOrChannel :: MH () -nextUnreadUserOrChannel = do +nextUnreadUserOrChannel :: TeamId -> MH () +nextUnreadUserOrChannel tId = do st <- use id - setReturnChannel - setFocusWith True (getNextUnreadUserOrChannel st) gotoReturnChannel + setReturnChannel tId + setFocusWith tId True (getNextUnreadUserOrChannel st tId) (return ()) (gotoReturnChannel tId) leaveChannel :: ChannelId -> MH () leaveChannel cId = leaveChannelIfPossible cId False @@ -765,8 +798,9 @@ ) getNextUnreadChannel :: ChatState + -> TeamId -> (Zipper a ChannelListEntry -> Zipper a ChannelListEntry) -getNextUnreadChannel st = +getNextUnreadChannel st tId = -- 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 @@ -774,26 +808,27 @@ -- for the next candidate channel. Z.findRight (\e -> let cId = channelListEntryChannelId e - in channelListEntryUnread e && (cId /= st^.csCurrentChannelId(st^.csCurrentTeamId))) + in channelListEntryUnread e && (Just cId /= st^.csCurrentChannelId(tId))) getNextUnreadUserOrChannel :: ChatState + -> TeamId -> Zipper a ChannelListEntry -> Zipper a ChannelListEntry -getNextUnreadUserOrChannel st z = +getNextUnreadUserOrChannel st tId z = -- Find the next unread channel, prefering direct messages - let cur = st^.csCurrentChannelId(st^.csCurrentTeamId) + let cur = st^.csCurrentChannelId(tId) matches e = entryIsDMEntry e && isFresh e - isFresh e = channelListEntryUnread e && (channelListEntryChannelId e /= cur) + isFresh e = channelListEntryUnread e && (Just (channelListEntryChannelId e) /= cur) in fromMaybe (Z.findRight isFresh z) (Z.maybeFindRight matches z) -leaveCurrentChannel :: MH () -leaveCurrentChannel = do - tId <- use csCurrentTeamId - use (csCurrentChannelId tId) >>= leaveChannel +leaveCurrentChannel :: TeamId -> MH () +leaveCurrentChannel tId = do + withCurrentChannel tId $ \cId _ -> do + leaveChannel cId -createGroupChannel :: Text -> MH () -createGroupChannel usernameList = do +createGroupChannel :: TeamId -> Text -> MH () +createGroupChannel tId usernameList = do me <- gets myUser session <- getSession cs <- use csChannels @@ -813,10 +848,9 @@ -- If we already know about the channel ID, -- that means the channel already exists so -- we can just switch to it. - setFocus (channelId chan) + setFocus tId (channelId chan) Nothing -> do - tId <- use csCurrentTeamId - csCurrentTeam.tsPendingChannelChange .= + csTeam(tId).tsPendingChannelChange .= (Just $ ChangeByChannelId tId (channelId chan) Nothing) let pref = showGroupChannelPref (channelId chan) (me^.userIdL) doAsyncWith Normal $ do @@ -830,52 +864,49 @@ return $ Just $ do forM_ missingUsernames (mhError . NoSuchUser) -channelHistoryForward :: MH () -channelHistoryForward = do - resetAutocomplete +channelHistoryForward :: TeamId -> MH () +channelHistoryForward tId = do + withCurrentChannel tId $ \cId _ -> do + resetAutocomplete tId - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - inputHistoryPos <- use (csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition) - case inputHistoryPos of - Just i - | i == 0 -> do - -- Transition out of history navigation - csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition .= Nothing - loadLastChannelInput - | otherwise -> do - let newI = i - 1 - loadHistoryEntryToEditor cId newI - csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI) - _ -> return () + inputHistoryPos <- use (csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition) + case inputHistoryPos of + Just i + | i == 0 -> do + -- Transition out of history navigation + csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition .= Nothing + loadLastChannelInput tId + | otherwise -> do + let newI = i - 1 + loadHistoryEntryToEditor tId cId newI + csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI) + _ -> return () -loadHistoryEntryToEditor :: ChannelId -> Int -> MH () -loadHistoryEntryToEditor cId idx = do +loadHistoryEntryToEditor :: TeamId -> ChannelId -> Int -> MH () +loadHistoryEntryToEditor tId cId idx = do inputHistory <- use csInputHistory case getHistoryEntry cId idx inputHistory of Nothing -> return () Just entry -> do let eLines = T.lines entry mv = if length eLines == 1 then gotoEOL else id - csCurrentTeam.tsEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing) + csTeam(tId).tsEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing) -channelHistoryBackward :: MH () -channelHistoryBackward = do - resetAutocomplete +channelHistoryBackward :: TeamId -> MH () +channelHistoryBackward tId = do + withCurrentChannel tId $ \cId _ -> do + resetAutocomplete tId - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - inputHistoryPos <- use (csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition) - saveCurrentChannelInput + inputHistoryPos <- use (csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition) + saveCurrentChannelInput tId - let newI = maybe 0 (+ 1) inputHistoryPos - loadHistoryEntryToEditor cId newI - csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI) + let newI = maybe 0 (+ 1) inputHistoryPos + loadHistoryEntryToEditor tId cId newI + csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI) -createOrdinaryChannel :: Bool -> Text -> MH () -createOrdinaryChannel public name = do +createOrdinaryChannel :: TeamId -> Bool -> Text -> MH () +createOrdinaryChannel myTId public name = do session <- getSession - myTId <- use csCurrentTeamId doAsyncWith Preempt $ do -- create a new chat channel let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name) @@ -903,93 +934,93 @@ member <- MM.mmGetChannelMember cId UserMe session tryMM (MM.mmGetChannel cId session) (\cwd -> return $ Just $ do - pending <- checkPendingChannelChange cId + mtId <- case channelTeamId cwd of + Nothing -> use csCurrentTeamId + Just i -> return $ Just i + pending <- case mtId of + Nothing -> return Nothing + Just tId -> checkPendingChannelChange tId cId handleNewChannel (isJust pending) SidebarUpdateImmediate cwd member) -addUserByNameToCurrentChannel :: Text -> MH () -addUserByNameToCurrentChannel uname = - withFetchedUser (UserFetchByUsername uname) addUserToCurrentChannel - -addUserToCurrentChannel :: UserInfo -> MH () -addUserToCurrentChannel u = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - session <- getSession - let channelMember = MinChannelMember (u^.uiId) cId - doAsyncWith Normal $ do - tryMM (void $ MM.mmAddUser cId channelMember session) - (const $ return Nothing) +addUserByNameToCurrentChannel :: TeamId -> Text -> MH () +addUserByNameToCurrentChannel tId uname = + withFetchedUser (UserFetchByUsername uname) (addUserToCurrentChannel tId) -removeUserFromCurrentChannel :: Text -> MH () -removeUserFromCurrentChannel uname = - withFetchedUser (UserFetchByUsername uname) $ \u -> do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) +addUserToCurrentChannel :: TeamId -> UserInfo -> MH () +addUserToCurrentChannel tId u = do + withCurrentChannel tId $ \cId _ -> do session <- getSession + let channelMember = MinChannelMember (u^.uiId) cId doAsyncWith Normal $ do - tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session) + tryMM (void $ MM.mmAddUser cId channelMember session) (const $ return Nothing) -startLeaveCurrentChannel :: MH () -startLeaveCurrentChannel = do - cInfo <- use (csCurrentChannel.ccInfo) - case cInfo^.cdType of - Direct -> hideDMChannel (cInfo^.cdChannelId) - Group -> hideDMChannel (cInfo^.cdChannelId) - _ -> setMode LeaveChannelConfirm +removeUserFromCurrentChannel :: TeamId -> Text -> MH () +removeUserFromCurrentChannel tId uname = + withCurrentChannel tId $ \cId _ -> do + withFetchedUser (UserFetchByUsername uname) $ \u -> do + session <- getSession + doAsyncWith Normal $ do + tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session) + (const $ return Nothing) -deleteCurrentChannel :: MH () -deleteCurrentChannel = do - setMode Main - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - leaveChannelIfPossible cId True +startLeaveCurrentChannel :: TeamId -> MH () +startLeaveCurrentChannel tId = do + withCurrentChannel tId $ \_ ch -> do + case ch^.ccInfo.cdType of + Direct -> hideDMChannel (ch^.ccInfo.cdChannelId) + Group -> hideDMChannel (ch^.ccInfo.cdChannelId) + _ -> setMode tId LeaveChannelConfirm -isCurrentChannel :: ChatState -> ChannelId -> Bool -isCurrentChannel st cId = st^.csCurrentChannelId(st^.csCurrentTeamId) == cId +deleteCurrentChannel :: TeamId -> MH () +deleteCurrentChannel tId = do + withCurrentChannel tId $ \cId _ -> do + setMode tId Main + leaveChannelIfPossible cId True -isRecentChannel :: ChatState -> ChannelId -> Bool -isRecentChannel st cId = st^.csCurrentTeam.tsRecentChannel == Just cId +isCurrentChannel :: ChatState -> TeamId -> ChannelId -> Bool +isCurrentChannel st tId cId = st^.csCurrentChannelId(tId) == Just cId -isReturnChannel :: ChatState -> ChannelId -> Bool -isReturnChannel st cId = st^.csCurrentTeam.tsReturnChannel == Just cId +isRecentChannel :: ChatState -> TeamId -> ChannelId -> Bool +isRecentChannel st tId cId = st^.csTeam(tId).tsRecentChannel == Just cId -joinChannelByName :: Text -> MH () -joinChannelByName rawName = do +isReturnChannel :: ChatState -> TeamId -> ChannelId -> Bool +isReturnChannel st tId cId = st^.csTeam(tId).tsReturnChannel == Just cId + +joinChannelByName :: TeamId -> Text -> MH () +joinChannelByName tId rawName = do session <- getSession - tId <- use csCurrentTeamId doAsyncWith Preempt $ do result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session return $ Just $ case result of Left (_::SomeException) -> mhError $ NoSuchChannel rawName - Right chan -> joinChannel $ getId chan + Right chan -> joinChannel tId $ getId chan -- | If the user is not a member of the specified channel, submit a -- request to join it. Otherwise switch to the channel. -joinChannel :: ChannelId -> MH () -joinChannel chanId = joinChannel' chanId Nothing +joinChannel :: TeamId -> ChannelId -> MH () +joinChannel tId chanId = joinChannel' tId chanId Nothing -joinChannel' :: ChannelId -> Maybe (MH ()) -> MH () -joinChannel' chanId act = do - setMode Main +joinChannel' :: TeamId -> ChannelId -> Maybe (MH ()) -> MH () +joinChannel' tId chanId act = do + setMode tId Main mChan <- preuse (csChannel(chanId)) case mChan of Just _ -> do - setFocus chanId + setFocus tId chanId fromMaybe (return ()) act Nothing -> do myId <- gets myUserId - tId <- use csCurrentTeamId let member = MinChannelMember myId chanId - csCurrentTeam.tsPendingChannelChange .= (Just $ ChangeByChannelId tId chanId act) + csTeam(tId).tsPendingChannelChange .= (Just $ ChangeByChannelId tId chanId act) doAsyncChannelMM Preempt chanId (\ s c -> MM.mmAddUser c member s) (const $ return act) -createOrFocusDMChannel :: UserInfo -> Maybe (ChannelId -> MH ()) -> MH () -createOrFocusDMChannel user successAct = do +createOrFocusDMChannel :: TeamId -> UserInfo -> Maybe (ChannelId -> MH ()) -> MH () +createOrFocusDMChannel tId user successAct = do cs <- use csChannels case getDmChannelFor (user^.uiId) cs of Just cId -> do - setFocus cId + setFocus tId cId case successAct of Nothing -> return () Just act -> act cId @@ -997,7 +1028,7 @@ -- We have a user of that name but no channel. Time to make one! myId <- gets myUserId session <- getSession - csCurrentTeam.tsPendingChannelChange .= (Just $ ChangeByUserId $ user^.uiId) + csTeam(tId).tsPendingChannelChange .= (Just $ ChangeByUserId $ user^.uiId) doAsyncWith Normal $ do -- create a new channel chan <- MM.mmCreateDirectMessageChannel (user^.uiId, myId) session @@ -1005,78 +1036,74 @@ -- | This switches to the named channel or creates it if it is a missing -- but valid user channel. -changeChannelByName :: Text -> MH () -changeChannelByName name = do +changeChannelByName :: TeamId -> Text -> MH () +changeChannelByName tId name = do myId <- gets myUserId - mCId <- gets (channelIdByChannelName name) + mCId <- gets (channelIdByChannelName tId name) mDMCId <- gets (channelIdByUsername name) withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do if (_uiId <$> foundUser) == Just myId then return () else do - setMode Main + setMode tId Main let err = mhError $ AmbiguousName name case (mCId, mDMCId) of (Nothing, Nothing) -> case foundUser of -- We know about the user but there isn't already a DM -- channel, so create one. - Just user -> createOrFocusDMChannel user Nothing + Just user -> createOrFocusDMChannel tId user Nothing -- There were no matches of any kind. Nothing -> mhError $ NoSuchChannel name (Just cId, Nothing) -- We matched a channel and there was an explicit sigil, so we -- don't care about the username match. - | normalChannelSigil `T.isPrefixOf` name -> setFocus cId + | normalChannelSigil `T.isPrefixOf` name -> setFocus tId 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 + | otherwise -> setFocus tId cId (Nothing, Just cId) -> -- We matched a DM channel only. - setFocus cId + setFocus tId cId (Just _, Just _) -> -- We matched both a channel and a DM channel. err -setChannelTopic :: Text -> MH () -setChannelTopic msg = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - let patch = defaultChannelPatch { channelPatchHeader = Just msg } - doAsyncChannelMM Preempt cId - (\s _ -> MM.mmPatchChannel cId patch s) - (\_ _ -> Nothing) +setChannelTopic :: TeamId -> Text -> MH () +setChannelTopic tId msg = do + withCurrentChannel tId $ \cId _ -> do + let patch = defaultChannelPatch { channelPatchHeader = Just msg } + doAsyncChannelMM Preempt cId + (\s _ -> MM.mmPatchChannel cId patch s) + (\_ _ -> Nothing) -- | This renames the current channel's url name. It makes a request -- to the server to change the name, but does not actually change the -- name in Matterhorn yet; that is handled by a websocket event handled -- asynchronously. -renameChannelUrl :: Text -> MH () -renameChannelUrl name = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - s <- getSession - let patch = defaultChannelPatch { channelPatchName = Just name } - doAsyncWith Normal $ do - _ <- MM.mmPatchChannel cId patch s - return Nothing +renameChannelUrl :: TeamId -> Text -> MH () +renameChannelUrl tId name = do + withCurrentChannel tId $ \cId _ -> do + s <- getSession + let patch = defaultChannelPatch { channelPatchName = Just name } + doAsyncWith Normal $ do + _ <- MM.mmPatchChannel cId patch s + return Nothing -getCurrentChannelTopic :: MH Text -getCurrentChannelTopic = do - ch <- use csCurrentChannel - return $ ch^.ccInfo.cdHeader +getCurrentChannelTopic :: TeamId -> MH (Maybe Text) +getCurrentChannelTopic tId = + withCurrentChannel' tId $ \_ c -> do + return $ Just $ c^.ccInfo.cdHeader -beginCurrentChannelDeleteConfirm :: MH () -beginCurrentChannelDeleteConfirm = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - withChannel cId $ \chan -> do +beginCurrentChannelDeleteConfirm :: TeamId -> MH () +beginCurrentChannelDeleteConfirm tId = do + withCurrentChannel tId $ \_ chan -> do let chType = chan^.ccInfo.cdType if chType /= Direct - then setMode DeleteChannelConfirm + then setMode tId DeleteChannelConfirm else mhError $ GenericError "Direct message channels cannot be deleted." updateChannelNotifyProps :: ChannelId -> ChannelNotifyProps -> MH () @@ -1085,25 +1112,78 @@ csChannel(cId).ccInfo.cdNotifyProps .= notifyProps updateSidebar (chan^.ccInfo.cdTeamId) -toggleChannelFavoriteStatus :: MH () -toggleChannelFavoriteStatus = do +toggleChannelFavoriteStatus :: TeamId -> MH () +toggleChannelFavoriteStatus tId = do myId <- gets myUserId - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - userPrefs <- use (csResources.crUserPreferences) - session <- getSession - let favPref = favoriteChannelPreference userPrefs cId - trueVal = "true" - prefVal = case favPref of - Just True -> "" - Just False -> trueVal - Nothing -> trueVal - pref = Preference - { preferenceUserId = myId - , preferenceCategory = PreferenceCategoryFavoriteChannel - , preferenceName = PreferenceName $ idString cId - , preferenceValue = PreferenceValue prefVal - } - doAsyncWith Normal $ do - MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session - return Nothing + withCurrentChannel tId $ \cId _ -> do + userPrefs <- use (csResources.crUserPreferences) + session <- getSession + let favPref = favoriteChannelPreference userPrefs cId + trueVal = "true" + prefVal = case favPref of + Just True -> "" + Just False -> trueVal + Nothing -> trueVal + pref = Preference + { preferenceUserId = myId + , preferenceCategory = PreferenceCategoryFavoriteChannel + , preferenceName = PreferenceName $ idString cId + , preferenceValue = PreferenceValue prefVal + } + doAsyncWith Normal $ do + MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session + return Nothing + +toggleChannelListGroupVisibility :: ChannelListGroupLabel -> MH () +toggleChannelListGroupVisibility label = do + withCurrentTeam $ \tId -> do + -- Get all channel list groups in the current sidebar that are + -- currently not collapsed + csHiddenChannelGroups %= \hidden -> + let s' = case HM.lookup tId hidden of + Nothing -> S.singleton label + Just s -> + if S.member label s + then S.delete label s + else S.insert label s + in HM.insert tId s' hidden + + updateSidebar Nothing + +toggleCurrentChannelChannelListGroup :: TeamId -> MH () +toggleCurrentChannelChannelListGroup tId = do + withCurrentChannel tId $ \_ _ -> do + z <- use (csTeam(tId).tsFocus) + case Z.focusHeading z of + Nothing -> return () + Just grp -> toggleChannelListGroupVisibility $ channelListGroupLabel grp + +toggleCurrentChannelChannelListGroupByName :: T.Text -> TeamId -> MH () +toggleCurrentChannelChannelListGroupByName name tId = do + withCurrentChannel tId $ \_ _ -> do + case lookup (T.toLower $ T.strip name) channelListGroupNames of + Nothing -> postErrorMessage' $ "Invalid group name: " <> name + Just l -> toggleChannelListGroupVisibility l + +channelListSortingModes :: [(ChannelListSorting, T.Text)] +channelListSortingModes = + [ (ChannelListSortDefault, "alphabetic") + , (ChannelListSortUnreadFirst, "alphabetic with unread channels first") + ] + +cycleChannelListSortingMode :: TeamId -> MH () +cycleChannelListSortingMode tId = do + curMode <- use (csTeam(tId).tsChannelListSorting) + + when (curMode `notElem` (fst <$> channelListSortingModes)) $ + error $ "BUG: active channel list sorting mode unknown (" <> show curMode <> ")" + + let (newMode, newModeDesc) = sortingModeAfter curMode + sortingModeAfter m = head $ drop 1 $ snd $ span ((/= m) . fst) $ + cycle channelListSortingModes + + postInfoMessage $ "Sorting channel list: " <> newModeDesc + + csTeam(tId).tsChannelListSorting .= newMode + + updateSidebar $ Just tId diff --git a/src/Matterhorn/State/Common.hs b/src/Matterhorn/State/Common.hs --- a/src/Matterhorn/State/Common.hs +++ b/src/Matterhorn/State/Common.hs @@ -127,21 +127,21 @@ -- | Add a 'ClientMessage' to the current channel's message list addClientMessage :: ClientMessage -> MH () addClientMessage msg = do - tId <- use csCurrentTeamId - cid <- use (csCurrentChannelId(tId)) - uuid <- generateUUID - let addCMsg = ccContents.cdMessages %~ - (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) - csChannels %= modifyChannelById cid addCMsg + withCurrentTeam $ \tId -> do + withCurrentChannel tId $ \cid _ -> do + uuid <- generateUUID + let addCMsg = ccContents.cdMessages %~ + (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) + csChannels %= modifyChannelById cid addCMsg - mh $ invalidateCacheEntry $ ChannelMessages cid - mh $ invalidateCacheEntry $ ChannelSidebar tId + mh $ invalidateCacheEntry $ ChannelMessages cid + mh $ invalidateCacheEntry $ ChannelSidebar tId - let msgTy = case msg^.cmType of - Error -> LogError - _ -> LogGeneral + let msgTy = case msg^.cmType of + Error -> LogError + _ -> LogGeneral - mhLog msgTy $ T.pack $ show msg + mhLog msgTy $ T.pack $ show msg -- | Add a new 'ClientMessage' representing an error message to -- the current channel's message list @@ -157,12 +157,17 @@ postErrorMessageIO :: Text -> ChatState -> IO ChatState postErrorMessageIO err st = do - msg <- newClientMessage Error err - uuid <- generateUUID_IO - let cId = st ^. csCurrentChannelId (st^.csCurrentTeamId) - addEMsg = ccContents.cdMessages %~ - (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) - return $ st & csChannels %~ modifyChannelById cId addEMsg + case st^.csCurrentTeamId of + Nothing -> return st + Just tId -> do + case st^.csCurrentChannelId(tId) of + Nothing -> return st + Just cId -> do + msg <- newClientMessage Error err + uuid <- generateUUID_IO + let addEMsg = ccContents.cdMessages %~ + (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) + return $ st & csChannels %~ modifyChannelById cId addEMsg openFilePath :: FilePath -> MH () openFilePath path = openWithOpener (return $ Right path) @@ -199,23 +204,23 @@ -- their interactive URL opener, when they -- return, any messages that arrive in the -- current channel will be displayed as new. - curChan <- use csCurrentChannel - let msgs = curChan^.ccContents.cdMessages - case findLatestUserMessage isEditable msgs of - Nothing -> return () - Just m -> - case m^.mOriginalPost of + withCurrentTeam $ \tId -> do + withCurrentChannel tId $ \cId curChan -> do + let msgs = curChan^.ccContents.cdMessages + case findLatestUserMessage isEditable msgs of Nothing -> return () - Just p -> - case curChan^.ccInfo.cdNewMessageIndicator of - Hide -> - csCurrentChannel.ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL)) - _ -> return () - -- No need to add a gap here: the websocket - -- disconnect/reconnect events will - -- automatically handle management of - -- messages delivered while suspended. + Just m -> + case m^.mOriginalPost of + Nothing -> return () + Just p -> + case curChan^.ccInfo.cdNewMessageIndicator of + Hide -> csChannel(cId).ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL)) + _ -> return () + -- No need to add a gap here: the websocket + -- disconnect/reconnect events will automatically + -- handle management of messages delivered while + -- suspended. mhSuspendAndResume $ \st -> do result <- runInteractiveCommand (T.unpack urlOpenCommand) [target] @@ -234,7 +239,9 @@ " exited with non-zero status " <> show code waitForKeypress - return $ setMode' Main st + return $ case st^.csCurrentTeamId of + Nothing -> st + Just tId -> setMode' tId Main st runInteractiveCommand :: String -> [String] @@ -277,9 +284,11 @@ Right (stdinResult, Just outh, Just errh, ph) -> do case stdinResult of Just inh -> do - let Just input = mInput - hPutStrLn inh input - hFlush inh + case mInput of + Just input -> do + hPutStrLn inh input + hFlush inh + Nothing -> return () Nothing -> return () ec <- waitForProcess ph diff --git a/src/Matterhorn/State/Editing.hs b/src/Matterhorn/State/Editing.hs --- a/src/Matterhorn/State/Editing.hs +++ b/src/Matterhorn/State/Editing.hs @@ -63,27 +63,27 @@ import Matterhorn.Types.Common ( sanitizeUserText' ) -startMultilineEditing :: MH () -startMultilineEditing = do +startMultilineEditing :: TeamId -> MH () +startMultilineEditing tId = do mh invalidateCache - csCurrentTeam.tsEditState.cedEphemeral.eesMultiline .= True + csTeam(tId).tsEditState.cedEphemeral.eesMultiline .= True -toggleMultilineEditing :: MH () -toggleMultilineEditing = do +toggleMultilineEditing :: TeamId -> MH () +toggleMultilineEditing tId = do mh invalidateCache - csCurrentTeam.tsEditState.cedEphemeral.eesMultiline %= not + csTeam(tId).tsEditState.cedEphemeral.eesMultiline %= not -- If multiline is now disabled and there is more than one line in -- the editor, that means we're showing the multiline message status -- (see Draw.Main.renderUserCommandBox.commandBox) so we want to be -- sure no autocomplete UI is present in case the cursor was left on -- a word that would otherwise show completion alternatives. - multiline <- use (csCurrentTeam.tsEditState.cedEphemeral.eesMultiline) - numLines <- use (csCurrentTeam.tsEditState.cedEditor.to getEditContents.to length) - when (not multiline && numLines > 1) resetAutocomplete + multiline <- use (csTeam(tId).tsEditState.cedEphemeral.eesMultiline) + numLines <- use (csTeam(tId).tsEditState.cedEditor.to getEditContents.to length) + when (not multiline && numLines > 1) (resetAutocomplete tId) -invokeExternalEditor :: MH () -invokeExternalEditor = do +invokeExternalEditor :: TeamId -> MH () +invokeExternalEditor tId = do -- If EDITOR is in the environment, write the current message to a -- temp file, invoke EDITOR on it, read the result, remove the temp -- file, and update the program state. @@ -96,7 +96,7 @@ Sys.withSystemTempFile "matterhorn_editor.md" $ \tmpFileName tmpFileHandle -> do -- Write the current message to the temp file Sys.hPutStr tmpFileHandle $ T.unpack $ T.intercalate "\n" $ - getEditContents $ st^.csCurrentTeam.tsEditState.cedEditor + getEditContents $ st^.csTeam(tId).tsEditState.cedEditor Sys.hClose tmpFileHandle -- Run the editor @@ -112,42 +112,42 @@ postErrorMessageIO "Failed to decode file contents as UTF-8" st Right t -> do let tmpLines = T.lines $ sanitizeUserText' t - return $ st & csCurrentTeam.tsEditState.cedEditor.editContentsL .~ (Z.textZipper tmpLines Nothing) + return $ st & csTeam(tId).tsEditState.cedEditor.editContentsL .~ (Z.textZipper tmpLines Nothing) Sys.ExitFailure _ -> return st -handlePaste :: BS.ByteString -> MH () -handlePaste bytes = do +handlePaste :: TeamId -> BS.ByteString -> MH () +handlePaste tId bytes = do let pasteStr = T.pack (UTF8.toString bytes) - csCurrentTeam.tsEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' pasteStr)) - contents <- use (csCurrentTeam.tsEditState.cedEditor.to getEditContents) + csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' pasteStr)) + contents <- use (csTeam(tId).tsEditState.cedEditor.to getEditContents) case length contents > 1 of - True -> startMultilineEditing + True -> startMultilineEditing tId False -> return () -editingPermitted :: ChatState -> Bool -editingPermitted st = - (length (getEditContents $ st^.csCurrentTeam.tsEditState.cedEditor) == 1) || - st^.csCurrentTeam.tsEditState.cedEphemeral.eesMultiline +editingPermitted :: ChatState -> TeamId -> Bool +editingPermitted st tId = + (length (getEditContents $ st^.csTeam(tId).tsEditState.cedEditor) == 1) || + st^.csTeam(tId).tsEditState.cedEphemeral.eesMultiline -messageEditingKeybindings :: KeyConfig -> KeyHandlerMap -messageEditingKeybindings kc = - let KeyHandlerMap m = editingKeybindings (csCurrentTeam.tsEditState.cedEditor) kc - in KeyHandlerMap $ M.map withUserTypingAction m +messageEditingKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +messageEditingKeybindings tId kc = + let KeyHandlerMap m = editingKeybindings tId (csTeam(tId).tsEditState.cedEditor) kc + in KeyHandlerMap $ M.map (withUserTypingAction tId) m -withUserTypingAction :: KeyHandler -> KeyHandler -withUserTypingAction kh = +withUserTypingAction :: TeamId -> KeyHandler -> KeyHandler +withUserTypingAction tId kh = kh { khHandler = newH } where oldH = khHandler kh newH = oldH { kehHandler = newKEH } oldKEH = kehHandler oldH - newKEH = oldKEH { ehAction = ehAction oldKEH >> sendUserTypingAction } + newKEH = oldKEH { ehAction = ehAction oldKEH >> sendUserTypingAction tId } -editingKeybindings :: Lens' ChatState (Editor T.Text Name) -> KeyConfig -> KeyHandlerMap -editingKeybindings editor = mkKeybindings $ editingKeyHandlers editor +editingKeybindings :: TeamId -> Lens' ChatState (Editor T.Text Name) -> KeyConfig -> KeyHandlerMap +editingKeybindings tId editor = mkKeybindings $ editingKeyHandlers tId editor -editingKeyHandlers :: Lens' ChatState (Editor T.Text Name) -> [KeyEventHandler] -editingKeyHandlers editor = +editingKeyHandlers :: TeamId -> Lens' ChatState (Editor T.Text Name) -> [KeyEventHandler] +editingKeyHandlers tId editor = [ mkKb EditorTransposeCharsEvent "Transpose the final two characters" (editor %= applyEdit Z.transposeChars) @@ -167,7 +167,7 @@ "Kill the line to the right of the current position and copy it" $ do z <- use (editor.editContentsL) let restOfLine = Z.currentLine (Z.killToBOL z) - csCurrentTeam.tsEditState.cedYankBuffer .= restOfLine + csTeam(tId).tsEditState.cedYankBuffer .= restOfLine editor %= applyEdit Z.killToEOL , mkKb EditorNextCharEvent "Move one character to the right" @@ -195,14 +195,16 @@ editor %= applyEdit gotoEnd , mkKb EditorYankEvent "Paste the current buffer contents at the cursor" $ do - buf <- use (csCurrentTeam.tsEditState.cedYankBuffer) + buf <- use (csTeam(tId).tsEditState.cedYankBuffer) editor %= applyEdit (Z.insertMany buf) ] -getEditorContent :: MH Text -getEditorContent = do - cmdLine <- use (csCurrentTeam.tsEditState.cedEditor) - let (line:rest) = getEditContents cmdLine +getEditorContent :: TeamId -> MH Text +getEditorContent tId = do + cmdLine <- use (csTeam(tId).tsEditState.cedEditor) + let (line, rest) = case getEditContents cmdLine of + (a:as) -> (a, as) + _ -> error "BUG: getEditorContent: got empty edit contents" return $ T.intercalate "\n" $ line : rest -- | Handle an input submission in the message editor. @@ -228,7 +230,7 @@ case T.uncons content of Just ('/', cmd) -> - dispatchCommand cmd + dispatchCommand tId cmd _ -> do attachments <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listElementsL) mode <- use (csTeam(tId).tsEditState.cedEditMode) @@ -237,11 +239,10 @@ -- Empty the attachment list only if a mesage is actually sent, since -- it's possible to /attach a file before actually sending the -- message - resetAttachmentList + resetAttachmentList tId -- Reset the autocomplete UI - resetAutocomplete - + resetAutocomplete tId -- Reset the edit mode *after* handling the input so that the input -- handler can tell whether we're editing, replying, etc. @@ -254,8 +255,8 @@ isSmartClosingPunctuation (EvKey (KChar c) []) = c `elem` closingPunctuationMarks isSmartClosingPunctuation _ = False -handleEditingInput :: Event -> MH () -handleEditingInput e = do +handleEditingInput :: TeamId -> Event -> MH () +handleEditingInput tId e = do -- Only handle input events to the editor if we permit editing: -- if multiline mode is off, or if there is only one line of text -- in the editor. This means we skip input this catch-all handler @@ -266,141 +267,140 @@ -- Record the input line count before handling the editing event -- so we can tell whether the editing event changes the line count -- later. - beforeLineCount <- use (csCurrentTeam.tsEditState.cedEditor.to getEditContents.to length) + beforeLineCount <- use (csTeam(tId).tsEditState.cedEditor.to getEditContents.to length) smartBacktick <- use (csResources.crConfiguration.configSmartBacktickL) let smartChars = "*`_" st <- use id - csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition .= Nothing + csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition .= Nothing smartEditing <- use (csResources.crConfiguration.configSmartEditingL) - justCompleted <- use (csCurrentTeam.tsEditState.cedJustCompleted) + justCompleted <- use (csTeam(tId).tsEditState.cedJustCompleted) conf <- use (csResources.crConfiguration) - let keyMap = editingKeybindings (csCurrentTeam.tsEditState.cedEditor) (configUserKeys conf) + let keyMap = editingKeybindings tId (csTeam(tId).tsEditState.cedEditor) (configUserKeys conf) case lookupKeybinding e keyMap of - Just kb | editingPermitted st -> (ehAction $ kehHandler $ khHandler kb) + Just kb | editingPermitted st tId -> (ehAction $ kehHandler $ khHandler kb) _ -> do case e of -- Not editing; backspace here means cancel multi-line message -- composition - EvKey KBS [] | (not $ editingPermitted st) -> - csCurrentTeam.tsEditState.cedEditor %= applyEdit Z.clearZipper + EvKey KBS [] | (not $ editingPermitted st tId) -> do + csTeam(tId).tsEditState.cedEditor %= applyEdit Z.clearZipper + mh invalidateCache -- Backspace in editing mode with smart pair insertion means -- smart pair removal when possible - EvKey KBS [] | editingPermitted st && smartBacktick -> - let backspace = csCurrentTeam.tsEditState.cedEditor %= applyEdit Z.deletePrevChar - in case cursorAtOneOf smartChars (st^.csCurrentTeam.tsEditState.cedEditor) of + EvKey KBS [] | editingPermitted st tId && smartBacktick -> + let backspace = csTeam(tId).tsEditState.cedEditor %= applyEdit Z.deletePrevChar + in case cursorAtOneOf smartChars (st^.csTeam(tId).tsEditState.cedEditor) of Nothing -> backspace Just ch -> -- Smart char removal: - if | (cursorAtChar ch $ applyEdit Z.moveLeft $ st^.csCurrentTeam.tsEditState.cedEditor) && - (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csCurrentTeam.tsEditState.cedEditor) -> - csCurrentTeam.tsEditState.cedEditor %= applyEdit (Z.deleteChar >>> Z.deletePrevChar) + if | (cursorAtChar ch $ applyEdit Z.moveLeft $ st^.csTeam(tId).tsEditState.cedEditor) && + (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csTeam(tId).tsEditState.cedEditor) -> + csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.deleteChar >>> Z.deletePrevChar) | otherwise -> backspace EvKey (KChar ch) [] - | editingPermitted st && smartBacktick && ch `elem` smartChars -> + | editingPermitted st tId && smartBacktick && ch `elem` smartChars -> -- Smart char insertion: let doInsertChar = do - csCurrentTeam.tsEditState.cedEditor %= applyEdit (Z.insertChar ch) - sendUserTypingAction - curLine = Z.currentLine $ st^.csCurrentTeam.tsEditState.cedEditor.editContentsL + csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertChar ch) + sendUserTypingAction tId + curLine = Z.currentLine $ st^.csTeam(tId).tsEditState.cedEditor.editContentsL -- First case: if the cursor is at the end of the current -- line and it contains "``" and the user entered a third -- "`", enable multi-line mode since they're likely typing -- a code block. - in if | (cursorIsAtEnd $ st^.csCurrentTeam.tsEditState.cedEditor) && + in if | (cursorIsAtEnd $ st^.csTeam(tId).tsEditState.cedEditor) && curLine == "``" && ch == '`' -> do - csCurrentTeam.tsEditState.cedEditor %= applyEdit (Z.insertMany (T.singleton ch)) - csCurrentTeam.tsEditState.cedEphemeral.eesMultiline .= True + csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertMany (T.singleton ch)) + csTeam(tId).tsEditState.cedEphemeral.eesMultiline .= True -- Second case: user entered some smart character -- (don't care which) on an empty line or at the end -- of the line after whitespace, so enter a pair of -- the smart chars and put the cursor between them. - | (editorEmpty $ st^.csCurrentTeam.tsEditState.cedEditor) || - ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csCurrentTeam.tsEditState.cedEditor)) && - (cursorIsAtEnd $ st^.csCurrentTeam.tsEditState.cedEditor)) -> - csCurrentTeam.tsEditState.cedEditor %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft) + | (editorEmpty $ st^.csTeam(tId).tsEditState.cedEditor) || + ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csTeam(tId).tsEditState.cedEditor)) && + (cursorIsAtEnd $ st^.csTeam(tId).tsEditState.cedEditor)) -> + csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft) -- Third case: the cursor is already on a smart -- character and that character is the last one -- on the line, so instead of inserting a new -- character, just move past it. - | (cursorAtChar ch $ st^.csCurrentTeam.tsEditState.cedEditor) && - (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csCurrentTeam.tsEditState.cedEditor) -> - csCurrentTeam.tsEditState.cedEditor %= applyEdit Z.moveRight + | (cursorAtChar ch $ st^.csTeam(tId).tsEditState.cedEditor) && + (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csTeam(tId).tsEditState.cedEditor) -> + csTeam(tId).tsEditState.cedEditor %= applyEdit Z.moveRight -- Fall-through case: just insert one of the chars -- without doing anything smart. | otherwise -> doInsertChar - | editingPermitted st -> do + | editingPermitted st tId -> do -- If the most recent editing event was a tab completion, -- there is a trailing space that we want to remove if the -- next input character is punctuation. when (smartEditing && justCompleted && isSmartClosingPunctuation e) $ - csCurrentTeam.tsEditState.cedEditor %= applyEdit Z.deletePrevChar + csTeam(tId).tsEditState.cedEditor %= applyEdit Z.deletePrevChar - csCurrentTeam.tsEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' $ T.singleton ch)) - sendUserTypingAction - _ | editingPermitted st -> do - mhHandleEventLensed (csCurrentTeam.tsEditState.cedEditor) handleEditorEvent e - sendUserTypingAction + csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' $ T.singleton ch)) + sendUserTypingAction tId + _ | editingPermitted st tId -> do + mhHandleEventLensed (csTeam(tId).tsEditState.cedEditor) handleEditorEvent e + sendUserTypingAction tId | otherwise -> return () let ctx = AutocompleteContext { autocompleteManual = False , autocompleteFirstMatch = False } - checkForAutocompletion ctx - liftIO $ resetSpellCheckTimer $ st^.csCurrentTeam.tsEditState + checkForAutocompletion tId ctx + liftIO $ resetSpellCheckTimer $ st^.csTeam(tId).tsEditState -- If the preview is enabled and multi-line editing is enabled and -- the line count changed, we need to invalidate the rendering cache -- entry for the channel messages because we want to redraw them to -- fit in the space just changed by the size of the preview area. - afterLineCount <- use (csCurrentTeam.tsEditState.cedEditor.to getEditContents.to length) - isMultiline <- use (csCurrentTeam.tsEditState.cedEphemeral.eesMultiline) + afterLineCount <- use (csTeam(tId).tsEditState.cedEditor.to getEditContents.to length) + isMultiline <- use (csTeam(tId).tsEditState.cedEphemeral.eesMultiline) isPreviewing <- use (csResources.crConfiguration.configShowMessagePreviewL) when (beforeLineCount /= afterLineCount && isMultiline && isPreviewing) $ do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - mh $ invalidateCacheEntry $ ChannelMessages cId + withCurrentChannel tId $ \cId _ -> do + mh $ invalidateCacheEntry $ ChannelMessages cId -- Reset the recent autocompletion flag to stop smart punctuation -- handling. when justCompleted $ - csCurrentTeam.tsEditState.cedJustCompleted .= False + csTeam(tId).tsEditState.cedJustCompleted .= False -- | Send the user_typing action to the server asynchronously, over the -- connected websocket. If the websocket is not connected, drop the -- action silently. -sendUserTypingAction :: MH () -sendUserTypingAction = do - st <- use id - when (configShowTypingIndicator (st^.csResources.crConfiguration)) $ - case st^.csConnectionStatus of - Connected -> do - let pId = case st^.csCurrentTeam.tsEditState.cedEditMode of - Replying _ post -> Just $ postId post - _ -> Nothing - tId <- use csCurrentTeamId - liftIO $ do - now <- getCurrentTime - let action = UserTyping now (st^.csCurrentChannelId(tId)) pId - STM.atomically $ STM.writeTChan (st^.csResources.crWebsocketActionChan) action - Disconnected -> return () +sendUserTypingAction :: TeamId -> MH () +sendUserTypingAction tId = do + withCurrentChannel tId $ \cId _ -> do + st <- use id + when (configSendTypingNotifications (st^.csResources.crConfiguration)) $ + case st^.csConnectionStatus of + Connected -> do + let pId = case st^.csTeam(tId).tsEditState.cedEditMode of + Replying _ post -> Just $ postId post + _ -> Nothing + liftIO $ do + now <- getCurrentTime + let action = UserTyping now cId pId + STM.atomically $ STM.writeTChan (st^.csResources.crWebsocketActionChan) action + Disconnected -> return () -- Kick off an async request to the spell checker for the current editor -- contents. -requestSpellCheck :: MH () -requestSpellCheck = do +requestSpellCheck :: TeamId -> MH () +requestSpellCheck tId = do st <- use id - case st^.csCurrentTeam.tsEditState.cedSpellChecker of + case st^.csTeam(tId).tsEditState.cedSpellChecker of Nothing -> return () Just (checker, _) -> do -- Get the editor contents. - tId <- use csCurrentTeamId contents <- getEditContents <$> use (csTeam(tId).tsEditState.cedEditor) doAsyncWith Preempt $ do -- For each line in the editor, submit an aspell request. @@ -457,41 +457,39 @@ then Z.moveCursor (numLines - 1, lastLineLength) z else z -cancelAutocompleteOrReplyOrEdit :: MH () -cancelAutocompleteOrReplyOrEdit = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - mh $ invalidateCacheEntry $ ChannelMessages cId - ac <- use (csCurrentTeam.tsEditState.cedAutocomplete) - case ac of - Just _ -> do - resetAutocomplete - Nothing -> do - mode <- use (csCurrentTeam.tsEditState.cedEditMode) - case mode of - NewPost -> return () - _ -> do - csCurrentTeam.tsEditState.cedEditMode .= NewPost - csCurrentTeam.tsEditState.cedEditor %= applyEdit Z.clearZipper - resetAttachmentList +cancelAutocompleteOrReplyOrEdit :: TeamId -> MH () +cancelAutocompleteOrReplyOrEdit tId = do + withCurrentChannel tId $ \cId _ -> do + mh $ invalidateCacheEntry $ ChannelMessages cId + ac <- use (csTeam(tId).tsEditState.cedAutocomplete) + case ac of + Just _ -> do + resetAutocomplete tId + Nothing -> do + mode <- use (csTeam(tId).tsEditState.cedEditMode) + case mode of + NewPost -> return () + _ -> do + csTeam(tId).tsEditState.cedEditMode .= NewPost + csTeam(tId).tsEditState.cedEditor %= applyEdit Z.clearZipper + resetAttachmentList tId -replyToLatestMessage :: MH () -replyToLatestMessage = do - msgs <- use (csCurrentChannel . ccContents . cdMessages) - case findLatestUserMessage isReplyable msgs of - Just msg | isReplyable msg -> - do rootMsg <- getReplyRootMessage msg - setMode Main - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - mh $ invalidateCacheEntry $ ChannelMessages cId - csCurrentTeam.tsEditState.cedEditMode .= Replying rootMsg (fromJust $ rootMsg^.mOriginalPost) - _ -> return () +replyToLatestMessage :: TeamId -> MH () +replyToLatestMessage tId = do + withCurrentChannel tId $ \cId chan -> do + let msgs = chan^. ccContents . cdMessages + case findLatestUserMessage isReplyable msgs of + Just msg | isReplyable msg -> + do rootMsg <- getReplyRootMessage msg + setMode tId Main + mh $ invalidateCacheEntry $ ChannelMessages cId + csTeam(tId).tsEditState.cedEditMode .= Replying rootMsg (fromJust $ rootMsg^.mOriginalPost) + _ -> return () data Direction = Forwards | Backwards -tabComplete :: Direction -> MH () -tabComplete dir = do +tabComplete :: TeamId -> Direction -> MH () +tabComplete tId dir = do let transform list = let len = list^.L.listElementsL.to length in case dir of @@ -505,15 +503,15 @@ (L.listSelected list == Nothing && len > 0) then L.listMoveTo (len - 1) list else L.listMoveBy (-1) list - csCurrentTeam.tsEditState.cedAutocomplete._Just.acCompletionList %= transform + csTeam(tId).tsEditState.cedAutocomplete._Just.acCompletionList %= transform - mac <- use (csCurrentTeam.tsEditState.cedAutocomplete) + mac <- use (csTeam(tId).tsEditState.cedAutocomplete) case mac of Nothing -> do let ctx = AutocompleteContext { autocompleteManual = True , autocompleteFirstMatch = True } - checkForAutocompletion ctx + checkForAutocompletion tId ctx Just ac -> do case ac^.acCompletionList.to L.listSelectedElement of Nothing -> return () @@ -523,12 +521,12 @@ if maybe True isSpace (Z.currentChar z) then z else Z.moveWordRight z - csCurrentTeam.tsEditState.cedEditor %= + csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertChar ' ' . Z.insertMany replacement . Z.deletePrevWord . maybeEndOfWord) - csCurrentTeam.tsEditState.cedJustCompleted .= True + csTeam(tId).tsEditState.cedJustCompleted .= True -- If there was only one completion alternative, -- hide the autocomplete listing now that we've -- completed the only completion. - when (ac^.acCompletionList.to L.listElements.to length == 1) resetAutocomplete + when (ac^.acCompletionList.to L.listElements.to length == 1) (resetAutocomplete tId) diff --git a/src/Matterhorn/State/Editing.hs-boot b/src/Matterhorn/State/Editing.hs-boot --- a/src/Matterhorn/State/Editing.hs-boot +++ b/src/Matterhorn/State/Editing.hs-boot @@ -4,7 +4,8 @@ ) where +import Network.Mattermost.Types ( TeamId ) import Matterhorn.Types ( MH ) data Direction = Forwards | Backwards -tabComplete :: Direction -> MH () +tabComplete :: TeamId -> Direction -> MH () diff --git a/src/Matterhorn/State/Help.hs b/src/Matterhorn/State/Help.hs --- a/src/Matterhorn/State/Help.hs +++ b/src/Matterhorn/State/Help.hs @@ -8,14 +8,16 @@ import Brick.Main ( viewportScroll, vScrollToBeginning ) +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.Types -showHelpScreen :: HelpTopic -> MH () -showHelpScreen topic = do - curMode <- use (csCurrentTeam.tsMode) +showHelpScreen :: TeamId -> HelpTopic -> MH () +showHelpScreen tId topic = do + curMode <- use (csTeam(tId).tsMode) case curMode of ShowHelp {} -> return () _ -> do mh $ vScrollToBeginning (viewportScroll HelpViewport) - setMode $ ShowHelp topic curMode + setMode tId $ ShowHelp topic curMode diff --git a/src/Matterhorn/State/ListOverlay.hs b/src/Matterhorn/State/ListOverlay.hs --- a/src/Matterhorn/State/ListOverlay.hs +++ b/src/Matterhorn/State/ListOverlay.hs @@ -19,7 +19,7 @@ import qualified Data.Text.Zipper as Z import qualified Data.Vector as Vec import Lens.Micro.Platform ( Lens', (%=), (.=) ) -import Network.Mattermost.Types ( Session ) +import Network.Mattermost.Types ( Session, TeamId ) import qualified Graphics.Vty as Vty import Matterhorn.Types @@ -30,21 +30,21 @@ -- | Activate the specified list overlay's selected item by invoking the -- overlay's configured enter keypress handler function. -listOverlayActivateCurrent :: Lens' ChatState (ListOverlayState a b) -> MH () -listOverlayActivateCurrent which = do +listOverlayActivateCurrent :: TeamId -> Lens' ChatState (ListOverlayState a b) -> MH () +listOverlayActivateCurrent tId which = do mItem <- L.listSelectedElement <$> use (which.listOverlaySearchResults) case mItem of Nothing -> return () - Just (_, val) -> listOverlayActivate which val + Just (_, val) -> listOverlayActivate tId which val -- | Activate the specified list overlay's selected item by invoking the -- overlay's configured enter keypress handler function. -listOverlayActivate :: Lens' ChatState (ListOverlayState a b) -> a -> MH () -listOverlayActivate which val = do +listOverlayActivate :: TeamId -> Lens' ChatState (ListOverlayState a b) -> a -> MH () +listOverlayActivate tId which val = do handler <- use (which.listOverlayEnterHandler) activated <- handler val if activated - then setMode Main + then setMode tId Main else return () -- | Get the current search string for the specified overlay. @@ -62,19 +62,21 @@ -- | Clear the state of the specified list overlay and return to the -- Main mode. -exitListOverlay :: Lens' ChatState (ListOverlayState a b) +exitListOverlay :: TeamId + -> Lens' ChatState (ListOverlayState a b) -- ^ Which overlay to reset -> MH () -exitListOverlay which = do +exitListOverlay tId which = do st <- use which newList <- use (which.listOverlayNewList) which.listOverlaySearchResults .= newList mempty which.listOverlayEnterHandler .= (const $ return False) - setMode (st^.listOverlayReturnMode) + setMode tId (st^.listOverlayReturnMode) -- | Initialize a list overlay with the specified arguments and switch -- to the specified mode. -enterListOverlayMode :: (Lens' ChatState (ListOverlayState a b)) +enterListOverlayMode :: TeamId + -> (Lens' ChatState (ListOverlayState a b)) -- ^ Which overlay to initialize -> Mode -- ^ The mode to change to @@ -85,7 +87,7 @@ -> (b -> Session -> Text -> IO (Vec.Vector a)) -- ^ The overlay's results fetcher function -> MH () -enterListOverlayMode which mode scope enterHandler fetcher = do +enterListOverlayMode tId which mode scope enterHandler fetcher = do which.listOverlaySearchScope .= scope which.listOverlaySearchInput.E.editContentsL %= Z.clearZipper which.listOverlayEnterHandler .= enterHandler @@ -93,7 +95,7 @@ which.listOverlaySearching .= False newList <- use (which.listOverlayNewList) which.listOverlaySearchResults .= newList mempty - setMode mode + setMode tId mode resetListOverlaySearch which -- | Reset the overlay's search by initiating a new search request for @@ -125,20 +127,21 @@ -- | Generically handle an event for the list overlay state targeted -- by the specified lens. Automatically dispatches new searches in the -- overlay's editor if the editor contents change. -onEventListOverlay :: Lens' ChatState (ListOverlayState a b) +onEventListOverlay :: TeamId + -> Lens' ChatState (ListOverlayState a b) -- ^ Which overlay to dispatch to? -> (KeyConfig -> KeyHandlerMap) -- ^ The keybinding builder -> Vty.Event -- ^ The event -> MH Bool -onEventListOverlay which keybindings = +onEventListOverlay tId which keybindings = handleKeyboardEvent keybindings $ \e -> do -- Get the editor content before the event. before <- listOverlaySearchString which -- First find a matching keybinding in the keybinding list. - handled <- handleKeyboardEvent (editingKeybindings (which.listOverlaySearchInput)) (const $ return ()) e + handled <- handleKeyboardEvent (editingKeybindings tId (which.listOverlaySearchInput)) (const $ return ()) e -- If we didn't find a matching binding, just handle the event -- as a normal editor input event. diff --git a/src/Matterhorn/State/MessageSelect.hs b/src/Matterhorn/State/MessageSelect.hs --- a/src/Matterhorn/State/MessageSelect.hs +++ b/src/Matterhorn/State/MessageSelect.hs @@ -31,6 +31,7 @@ import Brick ( invalidateCache ) import Brick.Widgets.Edit ( applyEdit ) import Data.Text.Zipper ( clearZipper, insertMany ) +import Data.Maybe ( fromJust ) import Lens.Micro.Platform import qualified Network.Mattermost.Endpoints as MM @@ -54,40 +55,43 @@ , ReactionEmojiListOverlay ] -getSelectedMessage :: ChatState -> Maybe Message -getSelectedMessage st - | not (st^.csCurrentTeam.tsMode `elem` messageSelectCompatibleModes) = Nothing +getSelectedMessage :: TeamId -> ChatState -> Maybe Message +getSelectedMessage tId st + | not (st^.csTeam(tId).tsMode `elem` messageSelectCompatibleModes) = Nothing | otherwise = do - selMsgId <- selectMessageId $ st^.csCurrentTeam.tsMessageSelect - let chanMsgs = st ^. csCurrentChannel . ccContents . cdMessages + selMsgId <- selectMessageId $ st^.csTeam(tId).tsMessageSelect + cId <- st^.csCurrentChannelId(tId) + chan <- st^?csChannel(cId) + let chanMsgs = chan ^. ccContents . cdMessages findMessage selMsgId chanMsgs -beginMessageSelect :: MH () -beginMessageSelect = do - -- Invalidate the rendering cache since we cache messages to speed - -- up the selection UI responsiveness. (See Draw.Messages for - -- caching behavior.) - mh invalidateCache +beginMessageSelect :: TeamId -> MH () +beginMessageSelect tId = do + withCurrentChannel tId $ \_ chan -> do + -- Invalidate the rendering cache since we cache messages to + -- speed up the selection UI responsiveness. (See Draw.Messages + -- for caching behavior.) + mh invalidateCache - -- Get the number of messages in the current channel and set the - -- currently selected message index to be the most recently received - -- message that corresponds to a Post (i.e. exclude informative - -- messages). - -- - -- If we can't find one at all, we ignore the mode switch request - -- and just return. - chanMsgs <- use(csCurrentChannel . ccContents . cdMessages) - let recentMsg = getLatestSelectableMessage chanMsgs + -- Get the number of messages in the current channel and set + -- the currently selected message index to be the most recently + -- received message that corresponds to a Post (i.e. exclude + -- informative messages). + -- + -- If we can't find one at all, we ignore the mode switch + -- request and just return. + let chanMsgs = chan ^. ccContents . cdMessages + recentMsg = getLatestSelectableMessage chanMsgs - when (isJust recentMsg) $ do - setMode MessageSelect - csCurrentTeam.tsMessageSelect .= MessageSelectState (recentMsg >>= _mMessageId) + when (isJust recentMsg) $ do + setMode tId MessageSelect + csTeam(tId).tsMessageSelect .= MessageSelectState (recentMsg >>= _mMessageId) -- | Tell the server that the message we currently have selected -- should have its flagged state toggled. -flagSelectedMessage :: MH () -flagSelectedMessage = do - selected <- use (to getSelectedMessage) +flagSelectedMessage :: TeamId -> MH () +flagSelectedMessage tId = do + selected <- use (to (getSelectedMessage tId)) case selected of Just msg | isFlaggable msg, Just pId <- messagePostId msg -> @@ -96,76 +100,73 @@ -- | Tell the server that the message we currently have selected -- should have its pinned state toggled. -pinSelectedMessage :: MH () -pinSelectedMessage = do - selected <- use (to getSelectedMessage) +pinSelectedMessage :: TeamId -> MH () +pinSelectedMessage tId = do + selected <- use (to (getSelectedMessage tId)) case selected of Just msg | isPinnable msg, Just pId <- messagePostId msg -> pinMessage pId (not (msg^.mPinned)) _ -> return () -viewSelectedMessage :: MH () -viewSelectedMessage = do - selected <- use (to getSelectedMessage) +viewSelectedMessage :: TeamId -> MH () +viewSelectedMessage tId = do + selected <- use (to (getSelectedMessage tId)) case selected of Just msg - | not (isGap msg) -> viewMessage msg + | not (isGap msg) -> viewMessage tId msg _ -> return () -copyPostLink :: MH () -copyPostLink = do - selected <- use (to getSelectedMessage) +fillSelectedGap :: TeamId -> MH () +fillSelectedGap tId = do + withCurrentChannel tId $ \cId _ -> do + selected <- use (to (getSelectedMessage tId)) + case selected of + Just msg + | isGap msg -> asyncFetchMessagesForGap cId msg + _ -> return () + +copyPostLink :: TeamId -> MH () +copyPostLink tId = do + selected <- use (to (getSelectedMessage tId)) case selected of Just msg | isPostMessage msg -> do - tId <- use csCurrentTeamId baseUrl <- getServerBaseUrl tId - let Just pId = messageIdPostId =<< _mMessageId msg + let pId = fromJust (messageIdPostId =<< _mMessageId msg) copyToClipboard $ makePermalink baseUrl pId - setMode Main + setMode tId Main _ -> return () -fillSelectedGap :: MH () -fillSelectedGap = do - selected <- use (to getSelectedMessage) - case selected of - Just msg - | isGap msg -> do tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - asyncFetchMessagesForGap cId msg - _ -> return () - -viewMessage :: Message -> MH () -viewMessage m = do - tId <- use csCurrentTeamId +viewMessage :: TeamId -> Message -> MH () +viewMessage tId m = do let w = tabbedWindow VMTabMessage (viewMessageWindowTemplate tId) MessageSelect (78, 25) - csCurrentTeam.tsViewedMessage .= Just (m, w) + csTeam(tId).tsViewedMessage .= Just (m, w) runTabShowHandlerFor (twValue w) w - setMode ViewMessage + setMode tId ViewMessage -yankSelectedMessageVerbatim :: MH () -yankSelectedMessageVerbatim = do - selectedMessage <- use (to getSelectedMessage) +yankSelectedMessageVerbatim :: TeamId -> MH () +yankSelectedMessageVerbatim tId = do + selectedMessage <- use (to (getSelectedMessage tId)) case selectedMessage of Nothing -> return () Just m -> do - setMode Main + setMode tId Main case findVerbatimChunk (m^.mText) of Just txt -> copyToClipboard txt Nothing -> return () -yankSelectedMessage :: MH () -yankSelectedMessage = do - selectedMessage <- use (to getSelectedMessage) +yankSelectedMessage :: TeamId -> MH () +yankSelectedMessage tId = do + selectedMessage <- use (to (getSelectedMessage tId)) case selectedMessage of Nothing -> return () Just m -> do - setMode Main + setMode tId Main copyToClipboard $ m^.mMarkdownSource -openSelectedMessageURLs :: MH () -openSelectedMessageURLs = whenMode MessageSelect $ do - mCurMsg <- use (to getSelectedMessage) +openSelectedMessageURLs :: TeamId -> MH () +openSelectedMessageURLs tId = whenMode tId MessageSelect $ do + mCurMsg <- use (to (getSelectedMessage tId)) curMsg <- case mCurMsg of Nothing -> error "BUG: openSelectedMessageURLs: no selected message available" Just m -> return m @@ -174,110 +175,116 @@ when (not (null urls)) $ do mapM_ (openLinkTarget . _linkTarget) urls -beginConfirmDeleteSelectedMessage :: MH () -beginConfirmDeleteSelectedMessage = do +beginConfirmDeleteSelectedMessage :: TeamId -> MH () +beginConfirmDeleteSelectedMessage tId = do st <- use id - selected <- use (to getSelectedMessage) + selected <- use (to (getSelectedMessage tId)) case selected of Just msg | isDeletable msg && isMine st msg -> - setMode MessageSelectDeleteConfirm + setMode tId MessageSelectDeleteConfirm _ -> return () -messageSelectUp :: MH () -messageSelectUp = do - mode <- use (csCurrentTeam.tsMode) - selected <- use (csCurrentTeam.tsMessageSelect.to selectMessageId) - case selected of - Just _ | mode == MessageSelect -> do - chanMsgs <- use (csCurrentChannel.ccContents.cdMessages) - let nextMsgId = getPrevMessageId selected chanMsgs - csCurrentTeam.tsMessageSelect .= MessageSelectState (nextMsgId <|> selected) - _ -> return () +messageSelectUp :: TeamId -> MH () +messageSelectUp tId = do + withCurrentChannel tId $ \_ chan -> do + mode <- use (csTeam(tId).tsMode) + selected <- use (csTeam(tId).tsMessageSelect.to selectMessageId) + case selected of + Just _ | mode == MessageSelect -> do + let chanMsgs = chan^.ccContents.cdMessages + nextMsgId = getPrevMessageId selected chanMsgs + csTeam(tId).tsMessageSelect .= MessageSelectState (nextMsgId <|> selected) + _ -> return () -messageSelectDown :: MH () -messageSelectDown = do - selected <- use (csCurrentTeam.tsMessageSelect.to selectMessageId) - case selected of - Just _ -> whenMode MessageSelect $ do - chanMsgs <- use (csCurrentChannel.ccContents.cdMessages) - let nextMsgId = getNextMessageId selected chanMsgs - csCurrentTeam.tsMessageSelect .= MessageSelectState (nextMsgId <|> selected) - _ -> return () +messageSelectDown :: TeamId -> MH () +messageSelectDown tId = do + withCurrentChannel tId $ \_ chan -> do + selected <- use (csTeam(tId).tsMessageSelect.to selectMessageId) + case selected of + Just _ -> + whenMode tId MessageSelect $ do + let chanMsgs = chan^.ccContents.cdMessages + nextMsgId = getNextMessageId selected chanMsgs + csTeam(tId).tsMessageSelect .= MessageSelectState (nextMsgId <|> selected) + _ -> return () -messageSelectDownBy :: Int -> MH () -messageSelectDownBy amt +messageSelectDownBy :: TeamId -> Int -> MH () +messageSelectDownBy tId amt | amt <= 0 = return () | otherwise = - messageSelectDown >> messageSelectDownBy (amt - 1) + messageSelectDown tId >> messageSelectDownBy tId (amt - 1) -messageSelectUpBy :: Int -> MH () -messageSelectUpBy amt +messageSelectUpBy :: TeamId -> Int -> MH () +messageSelectUpBy tId amt | amt <= 0 = return () | otherwise = - messageSelectUp >> messageSelectUpBy (amt - 1) + messageSelectUp tId >> messageSelectUpBy tId (amt - 1) -messageSelectFirst :: MH () -messageSelectFirst = do - selected <- use (csCurrentTeam.tsMessageSelect.to selectMessageId) - case selected of - Just _ -> whenMode MessageSelect $ do - chanMsgs <- use (csCurrentChannel.ccContents.cdMessages) - case getEarliestSelectableMessage chanMsgs of - Just firstMsg -> - csCurrentTeam.tsMessageSelect .= MessageSelectState (firstMsg^.mMessageId <|> selected) - Nothing -> mhLog LogError "No first message found from current message?!" - _ -> return () +messageSelectFirst :: TeamId -> MH () +messageSelectFirst tId = do + withCurrentChannel tId $ \_ chan -> do + selected <- use (csTeam(tId).tsMessageSelect.to selectMessageId) + case selected of + Just _ -> + whenMode tId MessageSelect $ do + let chanMsgs = chan^.ccContents.cdMessages + case getEarliestSelectableMessage chanMsgs of + Just firstMsg -> + csTeam(tId).tsMessageSelect .= MessageSelectState (firstMsg^.mMessageId <|> selected) + Nothing -> mhLog LogError "No first message found from current message?!" + _ -> return () -messageSelectLast :: MH () -messageSelectLast = do - selected <- use (csCurrentTeam.tsMessageSelect.to selectMessageId) - case selected of - Just _ -> whenMode MessageSelect $ do - chanMsgs <- use (csCurrentChannel.ccContents.cdMessages) - case getLatestSelectableMessage chanMsgs of - Just lastSelMsg -> - csCurrentTeam.tsMessageSelect .= MessageSelectState (lastSelMsg^.mMessageId <|> selected) - Nothing -> mhLog LogError "No last message found from current message?!" - _ -> return () +messageSelectLast :: TeamId -> MH () +messageSelectLast tId = do + withCurrentChannel tId $ \_ chan -> do + selected <- use (csTeam(tId).tsMessageSelect.to selectMessageId) + case selected of + Just _ -> + whenMode tId MessageSelect $ do + let chanMsgs = chan^.ccContents.cdMessages + case getLatestSelectableMessage chanMsgs of + Just lastSelMsg -> + csTeam(tId).tsMessageSelect .= MessageSelectState (lastSelMsg^.mMessageId <|> selected) + Nothing -> mhLog LogError "No last message found from current message?!" + _ -> return () -deleteSelectedMessage :: MH () -deleteSelectedMessage = do - selectedMessage <- use (to getSelectedMessage) - st <- use id - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - case selectedMessage of - Just msg | isMine st msg && isDeletable msg -> - case msg^.mOriginalPost of - Just p -> - doAsyncChannelMM Preempt cId - (\s _ -> MM.mmDeletePost (postId p) s) - (\_ _ -> Just $ do - csCurrentTeam.tsEditState.cedEditMode .= NewPost - setMode Main) - Nothing -> return () - _ -> return () +deleteSelectedMessage :: TeamId -> MH () +deleteSelectedMessage tId = do + withCurrentChannel tId $ \cId _ -> do + selectedMessage <- use (to (getSelectedMessage tId)) + st <- use id + case selectedMessage of + Just msg | isMine st msg && isDeletable msg -> + case msg^.mOriginalPost of + Just p -> + doAsyncChannelMM Preempt cId + (\s _ -> MM.mmDeletePost (postId p) s) + (\_ _ -> Just $ do + csTeam(tId).tsEditState.cedEditMode .= NewPost + setMode tId Main) + Nothing -> return () + _ -> return () -beginReplyCompose :: MH () -beginReplyCompose = do - selected <- use (to getSelectedMessage) +beginReplyCompose :: TeamId -> MH () +beginReplyCompose tId = do + selected <- use (to (getSelectedMessage tId)) case selected of Just msg | isReplyable msg -> do rootMsg <- getReplyRootMessage msg - let Just p = rootMsg^.mOriginalPost - setMode Main - csCurrentTeam.tsEditState.cedEditMode .= Replying rootMsg p + let p = fromJust $ rootMsg^.mOriginalPost + setMode tId Main + csTeam(tId).tsEditState.cedEditMode .= Replying rootMsg p _ -> return () -beginEditMessage :: MH () -beginEditMessage = do - selected <- use (to getSelectedMessage) +beginEditMessage :: TeamId -> MH () +beginEditMessage tId = do + selected <- use (to (getSelectedMessage tId)) st <- use id case selected of Just msg | isMine st msg && isEditable msg -> do - let Just p = msg^.mOriginalPost - setMode Main - csCurrentTeam.tsEditState.cedEditMode .= Editing p (msg^.mType) + let p = fromJust $ msg^.mOriginalPost + setMode tId Main + csTeam(tId).tsEditState.cedEditMode .= Editing p (msg^.mType) -- If the post that we're editing is an emote, we need -- to strip the formatting because that's only there to -- indicate that the post is an emote. This is annoying and @@ -289,7 +296,7 @@ let toEdit = if isEmote msg then removeEmoteFormatting sanitized else sanitized - csCurrentTeam.tsEditState.cedEditor %= applyEdit (insertMany toEdit . clearZipper) + csTeam(tId).tsEditState.cedEditor %= applyEdit (insertMany toEdit . clearZipper) _ -> return () -- | Tell the server that we have flagged or unflagged a message. diff --git a/src/Matterhorn/State/Messages.hs b/src/Matterhorn/State/Messages.hs --- a/src/Matterhorn/State/Messages.hs +++ b/src/Matterhorn/State/Messages.hs @@ -34,7 +34,7 @@ import qualified Data.Text as T import Graphics.Vty ( outputIface ) import Graphics.Vty.Output.Interface ( ringTerminalBell ) -import Lens.Micro.Platform ( Traversal', (.=), (%=), (%~), (.~), (^?) +import Lens.Micro.Platform ( Traversal', (.=), (%=), (%~), (.~) , to, at, traversed, filtered, ix, _1 ) import Network.Mattermost @@ -389,7 +389,7 @@ -- choice than allowing the user to perform select -- actions on a message that isn't the one they just -- selected. - setMode Main + setMode tId Main csTeam(tId).tsMessageSelect .= MessageSelectState Nothing -- Add a gap at each end of the newly fetched data, unless: @@ -557,8 +557,11 @@ when (isNothing authorResult) $ handleNewUsers (Seq.singleton authorId) (return ()) - curTId <- use csCurrentTeamId - currCId <- use (csCurrentChannelId curTId) + mcurTId <- use csCurrentTeamId + currCId <- case mcurTId of + Nothing -> return Nothing + Just curTId -> use (csCurrentChannelId curTId) + flags <- use (csResources.crFlaggedPosts) let (msg', mentionedUsers) = clientPostToMessage cp & _1.mFlagged .~ ((cp^.cpPostId) `Set.member` flags) @@ -572,7 +575,7 @@ csChannels %= modifyChannelById cId ((ccContents.cdMessages %~ addMessage msg') . (if not ignoredJoinLeaveMessage then adjustUpdated new else id) . - (\c -> if currCId == cId + (\c -> if currCId == Just cId then c else case newPostData of OldPost _ -> c @@ -606,22 +609,25 @@ postedChanMessage = withChannelOrDefault (postChannelId new) NoAction $ \chan -> do - currTid <- use csCurrentTeamId - currCId <- use (csCurrentChannelId currTid) + mcurrTid <- use csCurrentTeamId + case mcurrTid of + Nothing -> return NoAction + Just currTid -> do + currCId <- use (csCurrentChannelId currTid) - let notifyPref = notifyPreference (myUser st) chan - curChannelAction = if postChannelId new == currCId - then UpdateServerViewed - else NoAction - originUserAction = - if | fromMe -> NoAction - | ignoredJoinLeaveMessage -> NoAction - | notifyPref == NotifyOptionAll -> NotifyUser [newPostData] - | notifyPref == NotifyOptionMention - && wasMentioned -> NotifyUser [newPostData] - | otherwise -> NoAction + let notifyPref = notifyPreference (myUser st) chan + curChannelAction = if Just (postChannelId new) == currCId + then UpdateServerViewed + else NoAction + originUserAction = + if | fromMe -> NoAction + | ignoredJoinLeaveMessage -> NoAction + | notifyPref == NotifyOptionAll -> NotifyUser [newPostData] + | notifyPref == NotifyOptionMention + && wasMentioned -> NotifyUser [newPostData] + | otherwise -> NoAction - return $ curChannelAction `andProcessWith` originUserAction + return $ curChannelAction `andProcessWith` originUserAction doHandleAddedMessage @@ -788,27 +794,25 @@ -- messages to use as a starting point, but exceptions are new -- channels and empty channels. asyncFetchMoreMessages :: MH () -asyncFetchMoreMessages = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - withChannel cId $ \chan -> - let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2 - page = offset `div` pageAmount - usefulMsgs = getTwoContiguousPosts Nothing (chan^.ccContents.cdMessages.to reverseMessages) - sndOldestId = (messagePostId . snd) =<< usefulMsgs - query = MM.defaultPostQuery - { MM.postQueryPage = maybe (Just page) (const Nothing) sndOldestId - , MM.postQueryPerPage = Just pageAmount - , MM.postQueryBefore = sndOldestId - } - addTrailingGap = MM.postQueryBefore query == Nothing && - MM.postQueryPage query == Just 0 - in doAsyncChannelMM Preempt cId - (\s c -> MM.mmGetPostsForChannel c query s) - (\c p -> Just $ do - pp <- addObtainedMessages c (-pageAmount) addTrailingGap p - postProcessMessageAdd pp) - +asyncFetchMoreMessages = + withCurrentTeam $ \tId -> + withCurrentChannel tId $ \cId chan -> do + let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2 + page = offset `div` pageAmount + usefulMsgs = getTwoContiguousPosts Nothing (chan^.ccContents.cdMessages.to reverseMessages) + sndOldestId = (messagePostId . snd) =<< usefulMsgs + query = MM.defaultPostQuery + { MM.postQueryPage = maybe (Just page) (const Nothing) sndOldestId + , MM.postQueryPerPage = Just pageAmount + , MM.postQueryBefore = sndOldestId + } + addTrailingGap = MM.postQueryBefore query == Nothing && + MM.postQueryPage query == Just 0 + doAsyncChannelMM Preempt cId + (\s c -> MM.mmGetPostsForChannel c query s) + (\c p -> Just $ do + pp <- addObtainedMessages c (-pageAmount) addTrailingGap p + postProcessMessageAdd pp) -- | Given a starting point and a direction to move from that point, -- returns the closest two adjacent messages on that direction (as a @@ -906,13 +910,11 @@ let pl = toList $ postsOrder posts in if length pl > 1 then Just $ last $ init pl else Nothing -fetchVisibleIfNeeded :: MH () -fetchVisibleIfNeeded = do +fetchVisibleIfNeeded :: TeamId -> MH () +fetchVisibleIfNeeded tId = do sts <- use csConnectionStatus when (sts == Connected) $ do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - withChannel cId $ \chan -> do + withCurrentChannel tId $ \cId chan -> do let msgs = chan^.ccContents.cdMessages.to reverseMessages (numRemaining, gapInDisplayable, _, rel'pId, overlap) = foldl gapTrail (numScrollbackPosts, False, Nothing, Nothing, 2) msgs @@ -938,13 +940,12 @@ op = \s c -> MM.mmGetPostsForChannel c finalQuery s addTrailingGap = MM.postQueryBefore finalQuery == Nothing && MM.postQueryPage finalQuery == Just 0 - when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do - csChannel(cId).ccContents.cdFetchPending .= True - doAsyncChannelMM Preempt cId op - (\c p -> Just $ do - csChannel(c).ccContents.cdFetchPending .= False - addObtainedMessages c (-numToRequest) addTrailingGap p >>= postProcessMessageAdd) + csChannel(cId).ccContents.cdFetchPending .= True + doAsyncChannelMM Preempt cId op + (\c p -> Just $ do + csChannel(c).ccContents.cdFetchPending .= False + addObtainedMessages c (-numToRequest) addTrailingGap p >>= postProcessMessageAdd) asyncFetchAttachments :: Post -> MH () asyncFetchAttachments p = do @@ -981,7 +982,7 @@ -- reasonable effort will be made (fetch the post, join the channel) -- before giving up. jumpToPost :: PostId -> MH () -jumpToPost pId = do +jumpToPost pId = withCurrentTeam $ \tId -> do st <- use id case getMessageForPostId st pId of Just msg -> @@ -990,11 +991,11 @@ -- Are we a member of the channel? case findChannelById cId (st^.csChannels) of Nothing -> - joinChannel' cId (Just $ jumpToPost pId) + joinChannel' tId cId (Just $ jumpToPost pId) Just _ -> do - setFocus cId - setMode MessageSelect - csCurrentTeam.tsMessageSelect .= MessageSelectState (msg^.mMessageId) + setFocus tId cId + setMode tId MessageSelect + csTeam(tId).tsMessageSelect .= MessageSelectState (msg^.mMessageId) Nothing -> error "INTERNAL: selected Post ID not associated with a channel" Nothing -> do @@ -1009,7 +1010,7 @@ -- If not, join it and then try jumping to -- the post if the channel join is successful. Nothing -> do - joinChannel' (postChannelId p) (Just $ jumpToPost pId) + joinChannel' tId (postChannelId p) (Just $ jumpToPost pId) -- Otherwise add the post to the state and -- then jump. Just _ -> do diff --git a/src/Matterhorn/State/Messages.hs-boot b/src/Matterhorn/State/Messages.hs-boot --- a/src/Matterhorn/State/Messages.hs-boot +++ b/src/Matterhorn/State/Messages.hs-boot @@ -4,8 +4,9 @@ where import Matterhorn.Types ( MH ) +import Network.Mattermost.Types ( TeamId ) -- 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 () +fetchVisibleIfNeeded :: TeamId -> MH () diff --git a/src/Matterhorn/State/NotifyPrefs.hs b/src/Matterhorn/State/NotifyPrefs.hs --- a/src/Matterhorn/State/NotifyPrefs.hs +++ b/src/Matterhorn/State/NotifyPrefs.hs @@ -73,18 +73,17 @@ ] where radioStyle label = (padTop $ Pad 1 ) . (str label <=>) . (padLeft $ Pad 1) -enterEditNotifyPrefsMode :: MH () -enterEditNotifyPrefsMode = do - chanInfo <- use (csCurrentChannel.ccInfo) - case chanInfo^.cdType of - Direct -> mhError $ GenericError "Cannot open notification preferences for DM channel." - _ -> do - let props = chanInfo^.cdNotifyProps - user <- use csMe - tId <- use csCurrentTeamId - csCurrentTeam.tsNotifyPrefs .= (Just (notifyPrefsForm tId (userNotifyProps user) props)) - setMode EditNotifyPrefs +enterEditNotifyPrefsMode :: TeamId -> MH () +enterEditNotifyPrefsMode tId = + withCurrentChannel tId $ \_ chan -> do + case chan^.ccInfo.cdType of + Direct -> mhError $ GenericError "Cannot open notification preferences for DM channel." + _ -> do + let props = chan^.ccInfo.cdNotifyProps + user <- use csMe + csTeam(tId).tsNotifyPrefs .= (Just (notifyPrefsForm tId (userNotifyProps user) props)) + setMode tId EditNotifyPrefs -exitEditNotifyPrefsMode :: MH () -exitEditNotifyPrefsMode = do - setMode Main +exitEditNotifyPrefsMode :: TeamId -> MH () +exitEditNotifyPrefsMode tId = do + setMode tId Main diff --git a/src/Matterhorn/State/PostListOverlay.hs b/src/Matterhorn/State/PostListOverlay.hs --- a/src/Matterhorn/State/PostListOverlay.hs +++ b/src/Matterhorn/State/PostListOverlay.hs @@ -31,25 +31,24 @@ -- | Create a PostListOverlay with the given content description and -- with a specified list of messages. -enterPostListMode :: PostListContents -> Messages -> MH () -enterPostListMode contents msgs = do - csCurrentTeam.tsPostListOverlay.postListPosts .= msgs +enterPostListMode :: TeamId -> PostListContents -> Messages -> MH () +enterPostListMode tId contents msgs = do + csTeam(tId).tsPostListOverlay.postListPosts .= msgs let mlatest = getLatestPostMsg msgs pId = mlatest >>= messagePostId cId = mlatest >>= \m -> m^.mChannelId - csCurrentTeam.tsPostListOverlay.postListSelected .= pId - setMode $ PostListOverlay contents + csTeam(tId).tsPostListOverlay.postListSelected .= pId + setMode tId $ PostListOverlay contents case (pId, cId) of (Just p, Just c) -> asyncFetchMessagesSurrounding c p _ -> return () -- | Clear out the state of a PostListOverlay -exitPostListMode :: MH () -exitPostListMode = do - csCurrentTeam.tsPostListOverlay.postListPosts .= emptyDirSeq - csCurrentTeam.tsPostListOverlay.postListSelected .= Nothing - setMode Main - +exitPostListMode :: TeamId -> MH () +exitPostListMode tId = do + csTeam(tId).tsPostListOverlay.postListPosts .= emptyDirSeq + csTeam(tId).tsPostListOverlay.postListSelected .= Nothing + setMode tId Main createPostList :: TeamId -> PostListContents -> (Session -> IO Posts) -> MH () createPostList tId contentsType fetchOp = do @@ -66,48 +65,45 @@ , postsOrder = fromList [postId p] } mapM_ (\p -> addObtainedMessages (postChannelId p) 0 False $ postsSpec p) plist - enterPostListMode contentsType messages + enterPostListMode tId contentsType messages -- | Create a PostListOverlay with flagged messages from the server. -enterFlaggedPostListMode :: MH () -enterFlaggedPostListMode = do - tId <- use csCurrentTeamId +enterFlaggedPostListMode :: TeamId -> MH () +enterFlaggedPostListMode tId = do createPostList tId PostListFlagged $ mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery -- | Create a PostListOverlay with pinned messages from the server for -- the current channel. -enterPinnedPostListMode :: MH () -enterPinnedPostListMode = do - tId <- use csCurrentTeamId - cId <- use (csCurrentChannelId tId) - createPostList tId (PostListPinned cId) $ mmGetChannelPinnedPosts cId +enterPinnedPostListMode :: TeamId -> MH () +enterPinnedPostListMode tId = + withCurrentChannel tId $ \cId _ -> do + createPostList tId (PostListPinned cId) $ mmGetChannelPinnedPosts cId -- | Create a PostListOverlay with post search result messages from the -- server. -enterSearchResultPostListMode :: Text -> MH () -enterSearchResultPostListMode terms +enterSearchResultPostListMode :: TeamId -> Text -> MH () +enterSearchResultPostListMode tId terms | T.null (T.strip terms) = postInfoMessage "Search command requires at least one search term." | otherwise = do - enterPostListMode (PostListSearch terms True) noMessages - tId <- use csCurrentTeamId + enterPostListMode tId (PostListSearch terms True) noMessages createPostList tId (PostListSearch terms False) $ mmSearchForTeamPosts tId (SearchPosts terms False) -- | Move the selection up in the PostListOverlay, which corresponds -- to finding a chronologically /newer/ message. -postListSelectDown :: MH () -postListSelectDown = do - selId <- use (csCurrentTeam.tsPostListOverlay.postListSelected) - posts <- use (csCurrentTeam.tsPostListOverlay.postListPosts) +postListSelectDown :: TeamId -> MH () +postListSelectDown tId = do + selId <- use (csTeam(tId).tsPostListOverlay.postListSelected) + posts <- use (csTeam(tId).tsPostListOverlay.postListPosts) let nextMsg = getNextMessage (MessagePostId <$> selId) posts case nextMsg of Nothing -> return () Just m -> do let pId = m^.mMessageId >>= messageIdPostId - csCurrentTeam.tsPostListOverlay.postListSelected .= pId + csTeam(tId).tsPostListOverlay.postListSelected .= pId case (m^.mChannelId, pId) of (Just c, Just p) -> asyncFetchMessagesSurrounding c p o -> mhLog LogError @@ -116,16 +112,16 @@ -- | Move the selection down in the PostListOverlay, which corresponds -- to finding a chronologically /old/ message. -postListSelectUp :: MH () -postListSelectUp = do - selId <- use (csCurrentTeam.tsPostListOverlay.postListSelected) - posts <- use (csCurrentTeam.tsPostListOverlay.postListPosts) +postListSelectUp :: TeamId -> MH () +postListSelectUp tId = do + selId <- use (csTeam(tId).tsPostListOverlay.postListSelected) + posts <- use (csTeam(tId).tsPostListOverlay.postListPosts) let prevMsg = getPrevMessage (MessagePostId <$> selId) posts case prevMsg of Nothing -> return () Just m -> do let pId = m^.mMessageId >>= messageIdPostId - csCurrentTeam.tsPostListOverlay.postListSelected .= pId + csTeam(tId).tsPostListOverlay.postListSelected .= pId case (m^.mChannelId, pId) of (Just c, Just p) -> asyncFetchMessagesSurrounding c p o -> mhLog LogError @@ -133,9 +129,9 @@ " unable to get channel or post ID: " <> show o) -- | Unflag the post currently selected in the PostListOverlay, if any -postListUnflagSelected :: MH () -postListUnflagSelected = do - msgId <- use (csCurrentTeam.tsPostListOverlay.postListSelected) +postListUnflagSelected :: TeamId -> MH () +postListUnflagSelected tId = do + msgId <- use (csTeam(tId).tsPostListOverlay.postListSelected) case msgId of Nothing -> return () Just pId -> flagMessage pId False @@ -143,9 +139,9 @@ -- | Jumps to the specified message in the message's main channel -- display and changes to MessageSelectState. -postListJumpToCurrent :: MH () -postListJumpToCurrent = do - msgId <- use (csCurrentTeam.tsPostListOverlay.postListSelected) +postListJumpToCurrent :: TeamId -> MH () +postListJumpToCurrent tId = do + msgId <- use (csTeam(tId).tsPostListOverlay.postListSelected) case msgId of Nothing -> return () Just pId -> jumpToPost pId diff --git a/src/Matterhorn/State/ReactionEmojiListOverlay.hs b/src/Matterhorn/State/ReactionEmojiListOverlay.hs --- a/src/Matterhorn/State/ReactionEmojiListOverlay.hs +++ b/src/Matterhorn/State/ReactionEmojiListOverlay.hs @@ -30,21 +30,20 @@ import Matterhorn.State.Reactions ( updateReaction ) -enterReactionEmojiListOverlayMode :: MH () -enterReactionEmojiListOverlayMode = do - selectedMessage <- use (to getSelectedMessage) +enterReactionEmojiListOverlayMode :: TeamId -> MH () +enterReactionEmojiListOverlayMode tId = do + selectedMessage <- use (to (getSelectedMessage tId)) case selectedMessage of Nothing -> return () Just msg -> do - tId <- use csCurrentTeamId em <- use (csResources.crEmoji) myId <- gets myUserId - enterListOverlayMode (csTeam(tId).tsReactionEmojiListOverlay) ReactionEmojiListOverlay - () enterHandler (fetchResults myId msg em) + enterListOverlayMode tId (csTeam(tId).tsReactionEmojiListOverlay) ReactionEmojiListOverlay + () (enterHandler tId) (fetchResults myId msg em) -enterHandler :: (Bool, T.Text) -> MH Bool -enterHandler (mine, e) = do - selectedMessage <- use (to getSelectedMessage) +enterHandler :: TeamId -> (Bool, T.Text) -> MH Bool +enterHandler tId (mine, e) = do + selectedMessage <- use (to (getSelectedMessage tId)) case selectedMessage of Nothing -> return False Just m -> do @@ -86,28 +85,28 @@ matchingCurrentOtherReactions <> matchingCurrentMyReactions <> ((False,) <$> serverMatches) -- | Move the selection up in the emoji list overlay by one emoji. -reactionEmojiListSelectUp :: MH () -reactionEmojiListSelectUp = reactionEmojiListMove L.listMoveUp +reactionEmojiListSelectUp :: TeamId -> MH () +reactionEmojiListSelectUp tId = reactionEmojiListMove tId L.listMoveUp -- | Move the selection down in the emoji list overlay by one emoji. -reactionEmojiListSelectDown :: MH () -reactionEmojiListSelectDown = reactionEmojiListMove L.listMoveDown +reactionEmojiListSelectDown :: TeamId -> MH () +reactionEmojiListSelectDown tId = reactionEmojiListMove tId L.listMoveDown -- | Move the selection up in the emoji list overlay by a page of emoji -- (ReactionEmojiListPageSize). -reactionEmojiListPageUp :: MH () -reactionEmojiListPageUp = reactionEmojiListMove (L.listMoveBy (-1 * reactionEmojiListPageSize)) +reactionEmojiListPageUp :: TeamId -> MH () +reactionEmojiListPageUp tId = reactionEmojiListMove tId (L.listMoveBy (-1 * reactionEmojiListPageSize)) -- | Move the selection down in the emoji list overlay by a page of emoji -- (ReactionEmojiListPageSize). -reactionEmojiListPageDown :: MH () -reactionEmojiListPageDown = reactionEmojiListMove (L.listMoveBy reactionEmojiListPageSize) +reactionEmojiListPageDown :: TeamId -> MH () +reactionEmojiListPageDown tId = reactionEmojiListMove tId (L.listMoveBy reactionEmojiListPageSize) -- | Transform the emoji list results in some way, e.g. by moving the -- cursor, and then check to see whether the modification warrants a -- prefetch of more search results. -reactionEmojiListMove :: (L.List Name (Bool, T.Text) -> L.List Name (Bool, T.Text)) -> MH () -reactionEmojiListMove = listOverlayMove (csCurrentTeam.tsReactionEmojiListOverlay) +reactionEmojiListMove :: TeamId -> (L.List Name (Bool, T.Text) -> L.List Name (Bool, T.Text)) -> MH () +reactionEmojiListMove tId = listOverlayMove (csTeam(tId).tsReactionEmojiListOverlay) -- | The number of emoji in a "page" for cursor movement purposes. reactionEmojiListPageSize :: Int diff --git a/src/Matterhorn/State/SaveAttachmentWindow.hs b/src/Matterhorn/State/SaveAttachmentWindow.hs --- a/src/Matterhorn/State/SaveAttachmentWindow.hs +++ b/src/Matterhorn/State/SaveAttachmentWindow.hs @@ -9,7 +9,7 @@ import Lens.Micro.Platform ( (.=), to ) -import Network.Mattermost.Types ( fileInfoName ) +import Network.Mattermost.Types ( TeamId, fileInfoName ) import Network.Mattermost.Endpoints ( mmGetMetadataForFile ) import Matterhorn.Types @@ -21,21 +21,20 @@ -- to save the attachment. If the URL list is empty or if the selected -- entry is not for an attachment, this returns to the Main mode but -- otherwise does nothing. -openSaveAttachmentWindow :: MH () -openSaveAttachmentWindow = do - selected <- use (csCurrentTeam.tsUrlList.to listSelectedElement) +openSaveAttachmentWindow :: TeamId -> MH () +openSaveAttachmentWindow tId = do + selected <- use (csTeam(tId).tsUrlList.to listSelectedElement) case selected of Nothing -> return () Just (_, (_, link)) -> case link^.linkTarget of LinkFileId fId -> do - tId <- use csCurrentTeamId session <- getSession doAsyncWith Normal $ do info <- mmGetMetadataForFile fId session return $ Just $ do - csCurrentTeam.tsSaveAttachmentDialog .= newSaveAttachmentDialog tId (fileInfoName info) - setMode $ SaveAttachmentWindow link + csTeam(tId).tsSaveAttachmentDialog .= newSaveAttachmentDialog tId (fileInfoName info) + setMode tId $ SaveAttachmentWindow link _ -> -- The selected link is not for an attachment. return () diff --git a/src/Matterhorn/State/Setup.hs b/src/Matterhorn/State/Setup.hs --- a/src/Matterhorn/State/Setup.hs +++ b/src/Matterhorn/State/Setup.hs @@ -33,25 +33,25 @@ import Matterhorn.Themes import Matterhorn.TimeUtils ( lookupLocalTimeZone, utcTimezone ) import Matterhorn.Types -import Matterhorn.Types.Common import Matterhorn.Emoji import Matterhorn.FilePaths ( userEmojiJsonPath, bundledEmojiJsonPath ) incompleteCredentials :: Config -> ConnectionInfo -incompleteCredentials config = ConnectionInfo - { _ciHostname = fromMaybe "" (configHost config) - , _ciPort = configPort config - , _ciUrlPath = fromMaybe "" (configUrlPath config) - , _ciUsername = fromMaybe "" (configUser config) - , _ciPassword = case configPass config of - Just (PasswordString s) -> s - _ -> "" - , _ciAccessToken = case configToken config of - Just (TokenString s) -> s - _ -> "" - , _ciType = configConnectionType config - } +incompleteCredentials config = + ConnectionInfo { _ciHostname = fromMaybe "" (configHost config) + , _ciPort = configPort config + , _ciUrlPath = fromMaybe "" (configUrlPath config) + , _ciUsername = fromMaybe "" (configUser config) + , _ciPassword = case configPass config of + Just (PasswordString s) -> s + _ -> "" + , _ciOTPToken = Nothing + , _ciAccessToken = case configToken config of + Just (TokenString s) -> s + _ -> "" + , _ciType = configConnectionType config + } apiLogEventToLogMessage :: LogEvent -> IO LogMessage apiLogEventToLogMessage ev = do @@ -66,177 +66,166 @@ setupState :: IO Vty.Vty -> Maybe FilePath -> Config -> IO (ChatState, Vty.Vty) setupState mkVty mLogLocation config = do - initialVty <- mkVty - - eventChan <- newBChan 2500 - logMgr <- newLogManager eventChan (configLogMaxBufferSize config) + initialVty <- mkVty - -- If we got an initial log location, start logging there. - case mLogLocation of - Nothing -> return () - Just loc -> startLoggingToFile logMgr loc + eventChan <- newBChan 2500 + logMgr <- newLogManager eventChan (configLogMaxBufferSize config) - let logApiEvent ev = apiLogEventToLogMessage ev >>= sendLogMessage logMgr - setLogger cd = cd `withLogger` logApiEvent + -- If we got an initial log location, start logging there. + case mLogLocation of + Nothing -> return () + Just loc -> startLoggingToFile logMgr loc - (mLastAttempt, loginVty) <- interactiveGetLoginSession initialVty mkVty - setLogger - logMgr - (incompleteCredentials config) + let logApiEvent ev = apiLogEventToLogMessage ev >>= sendLogMessage logMgr + setLogger cd = cd `withLogger` logApiEvent - let shutdown vty = do - Vty.shutdown vty - exitSuccess + (mLoginSuccess, loginVty) <- interactiveGetLoginSession initialVty mkVty + setLogger + logMgr + (incompleteCredentials config) - (session, me, cd, mbTeam) <- case mLastAttempt of - Nothing -> - -- The user never attempted a connection and just chose to - -- quit. - shutdown loginVty - Just (AttemptFailed {}) -> - -- The user attempted a connection and failed, and then chose - -- to quit. - shutdown loginVty - Just (AttemptSucceeded _ cd sess user mbTeam) -> - -- The user attempted a connection and succeeded so continue - -- with setup. - return (sess, user, cd, mbTeam) + let shutdown vty = do + Vty.shutdown vty + exitSuccess - teams <- F.toList <$> mmGetUsersTeams UserMe session - when (null teams) $ do - putStrLn "Error: your account is not a member of any teams" - exitFailure + (session, me, cd, mbTeam) <- case mLoginSuccess of + Nothing -> + -- The user never attempted a connection and just chose to + -- quit. + shutdown loginVty + Just (LoginSuccess cd sess user mbTeam) -> + -- The user attempted a connection and succeeded so continue + -- with setup. + return (sess, user, cd, mbTeam) - let initialTeamId = fromMaybe (teamId $ head $ sortTeams teams) $ do - tName <- mbTeam <|> configTeam config - let matchingTeam = listToMaybe $ filter (matchesTeam tName) teams - teamId <$> matchingTeam + teams <- F.toList <$> mmGetUsersTeams UserMe session + when (null teams) $ do + putStrLn "Error: your account is not a member of any teams" + exitFailure - userStatusChan <- STM.newTChanIO - slc <- STM.newTChanIO - wac <- STM.newTChanIO + let initialTeamId = fromMaybe (teamId $ head $ sortTeams teams) $ do + tName <- mbTeam <|> configTeam config + let matchingTeam = listToMaybe $ filter (matchesTeam tName) teams + teamId <$> matchingTeam - prefs <- mmGetUsersPreferences UserMe session - let userPrefs = setUserPreferences prefs defaultUserPreferences - themeName = case configTheme config of - Nothing -> internalThemeName defaultTheme - Just t -> t - baseTheme = internalTheme $ fromMaybe defaultTheme (lookupTheme themeName) + userStatusChan <- STM.newTChanIO + slc <- STM.newTChanIO + wac <- STM.newTChanIO - -- Did the configuration specify a theme customization file? If so, - -- load it and customize the theme. - custTheme <- case configThemeCustomizationFile config of - Nothing -> return baseTheme - Just path -> - -- If we have no configuration path (i.e. we used the default - -- config) then ignore theme customization. - let pathStr = T.unpack path - in if isRelative pathStr && isNothing (configAbsPath config) - then return baseTheme - else do - let absPath = if isRelative pathStr - then (dropFileName $ fromJust $ configAbsPath config) pathStr - else pathStr - result <- loadCustomizations absPath baseTheme - case result of - Left e -> do - Vty.shutdown loginVty - putStrLn $ "Error loading theme customization from " <> show absPath <> ": " <> e - exitFailure - Right t -> return t + prefs <- mmGetUsersPreferences UserMe session + let userPrefs = setUserPreferences prefs defaultUserPreferences + themeName = case configTheme config of + Nothing -> internalThemeName defaultTheme + Just t -> t + baseTheme = internalTheme $ fromMaybe defaultTheme (lookupTheme themeName) - requestChan <- STM.atomically STM.newTChan + -- Did the configuration specify a theme customization file? If so, + -- load it and customize the theme. + custTheme <- case configThemeCustomizationFile config of + Nothing -> return baseTheme + Just path -> + -- If we have no configuration path (i.e. we used the default + -- config) then ignore theme customization. + let pathStr = T.unpack path + in if isRelative pathStr && isNothing (configAbsPath config) + then return baseTheme + else do + let absPath = if isRelative pathStr + then (dropFileName $ fromJust $ configAbsPath config) pathStr + else pathStr + result <- loadCustomizations absPath baseTheme + case result of + Left e -> do + Vty.shutdown loginVty + putStrLn $ "Error loading theme customization from " <> show absPath <> ": " <> e + exitFailure + Right t -> return t - emoji <- either (const emptyEmojiCollection) id <$> do - result1 <- loadEmoji =<< userEmojiJsonPath - case result1 of - Right e -> return $ Right e - Left _ -> loadEmoji =<< bundledEmojiJsonPath + requestChan <- STM.atomically STM.newTChan - let cr = ChatResources { _crSession = session - , _crWebsocketThreadId = Nothing - , _crConn = cd - , _crRequestQueue = requestChan - , _crEventQueue = eventChan - , _crSubprocessLog = slc - , _crWebsocketActionChan = wac - , _crTheme = themeToAttrMap custTheme - , _crStatusUpdateChan = userStatusChan - , _crConfiguration = config - , _crFlaggedPosts = mempty - , _crUserPreferences = userPrefs - , _crSyntaxMap = mempty - , _crLogManager = logMgr - , _crEmoji = emoji - } + emoji <- either (const emptyEmojiCollection) id <$> do + result1 <- loadEmoji =<< userEmojiJsonPath + case result1 of + Right e -> return $ Right e + Left _ -> loadEmoji =<< bundledEmojiJsonPath - st <- initializeState cr initialTeamId teams me + let cr = ChatResources { _crSession = session + , _crWebsocketThreadId = Nothing + , _crConn = cd + , _crRequestQueue = requestChan + , _crEventQueue = eventChan + , _crSubprocessLog = slc + , _crWebsocketActionChan = wac + , _crTheme = themeToAttrMap custTheme + , _crStatusUpdateChan = userStatusChan + , _crConfiguration = config + , _crFlaggedPosts = mempty + , _crUserPreferences = userPrefs + , _crSyntaxMap = mempty + , _crLogManager = logMgr + , _crEmoji = emoji + } - return (st, loginVty) + st <- initializeState cr initialTeamId teams me -matchesTeam :: T.Text -> Team -> Bool -matchesTeam tName t = - let normalizeUserText = normalize . sanitizeUserText - normalize = T.strip . T.toLower - urlName = normalizeUserText $ teamName t - displayName = normalizeUserText $ teamDisplayName t - in normalize tName `elem` [displayName, urlName] + return (st, loginVty) initializeState :: ChatResources -> TeamId -> [Team] -> User -> IO ChatState initializeState cr initialTeamId teams me = do - let session = getResourceSession cr - requestChan = cr^.crRequestQueue + let session = getResourceSession cr + requestChan = cr^.crRequestQueue - tz <- fromRight utcTimezone <$> lookupLocalTimeZone + tz <- fromRight utcTimezone <$> lookupLocalTimeZone - hist <- do - result <- readHistory - case result of - Left _ -> return newHistory - Right h -> return h + hist <- do + result <- readHistory + case result of + Left _ -> return newHistory + Right h -> return h - -------------------------------------------------------------------- - -- Start background worker threads: - -- - -- * Syntax definition loader - startSyntaxMapLoaderThread (cr^.crConfiguration) (cr^.crEventQueue) + -------------------------------------------------------------------- + -- Start background worker threads: + -- + -- * Syntax definition loader + startSyntaxMapLoaderThread (cr^.crConfiguration) (cr^.crEventQueue) - -- * Main async queue worker thread - startAsyncWorkerThread (cr^.crConfiguration) (cr^.crRequestQueue) (cr^.crEventQueue) + -- * Main async queue worker thread + startAsyncWorkerThread (cr^.crConfiguration) (cr^.crRequestQueue) (cr^.crEventQueue) - -- * User status thread - startUserStatusUpdateThread (cr^.crStatusUpdateChan) session requestChan + -- * User status thread + startUserStatusUpdateThread (cr^.crStatusUpdateChan) session requestChan - -- * Refresher for users who are typing currently - when (configShowTypingIndicator (cr^.crConfiguration)) $ - startTypingUsersRefreshThread requestChan + -- * Refresher for users who are typing currently + when (configShowTypingIndicator (cr^.crConfiguration)) $ + startTypingUsersRefreshThread requestChan - -- * Timezone change monitor - startTimezoneMonitorThread tz requestChan + -- * Timezone change monitor + startTimezoneMonitorThread tz requestChan - -- * Subprocess logger - startSubprocessLoggerThread (cr^.crSubprocessLog) requestChan + -- * Subprocess logger + startSubprocessLoggerThread (cr^.crSubprocessLog) requestChan - -- End thread startup ---------------------------------------------- + -- End thread startup ---------------------------------------------- - -- For each team, build a team state and load the last-run state. - (teamStates, chanLists) <- unzip <$> mapM (buildTeamState cr me) teams + -- For each team, build a team state and load that team's last-run + -- state, if any. + (teamStates, chanLists) <- unzip <$> mapM (buildTeamState cr me) teams - let startupState = - StartupStateInfo { startupStateResources = cr - , startupStateConnectedUser = me - , startupStateTimeZone = tz - , startupStateInitialHistory = hist - , startupStateInitialTeam = initialTeamId - , startupStateTeams = teamMap - } - clientChans = mconcat chanLists - st = newState startupState & csChannels .~ clientChans - teamMap = HM.fromList $ (\ts -> (teamId $ _tsTeam ts, ts)) <$> F.toList teamStates + let startupState = + StartupStateInfo { startupStateResources = cr + , startupStateConnectedUser = me + , startupStateTimeZone = tz + , startupStateInitialHistory = hist + , startupStateInitialTeam = initialTeamId + , startupStateTeams = teamMap + } + clientChans = mconcat chanLists + st = newState startupState & csChannels .~ clientChans + teamMap = HM.fromList $ (\ts -> (teamId $ _tsTeam ts, ts)) <$> F.toList teamStates - loadFlaggedMessages (cr^.crUserPreferences.userPrefFlaggedPostList) st + loadFlaggedMessages (cr^.crUserPreferences.userPrefFlaggedPostList) st - -- Trigger an initial websocket refresh - writeBChan (cr^.crEventQueue) RefreshWebsocketEvent + -- Trigger an initial websocket refresh + writeBChan (cr^.crEventQueue) RefreshWebsocketEvent - return st + return st diff --git a/src/Matterhorn/State/Setup/Threads.hs b/src/Matterhorn/State/Setup/Threads.hs --- a/src/Matterhorn/State/Setup/Threads.hs +++ b/src/Matterhorn/State/Setup/Threads.hs @@ -159,8 +159,8 @@ void $ forkIO (timezoneMonitor tz) -maybeStartSpellChecker :: Config -> BChan MHEvent -> IO (Maybe (Aspell, IO ())) -maybeStartSpellChecker config eventQueue = do +maybeStartSpellChecker :: TeamId -> Config -> BChan MHEvent -> IO (Maybe (Aspell, IO ())) +maybeStartSpellChecker tId config eventQueue = do case configEnableAspell config of False -> return Nothing True -> do @@ -171,7 +171,7 @@ case asResult of Nothing -> return Nothing Just as -> do - resetSCChan <- startSpellCheckerThread eventQueue spellCheckerTimeout + resetSCChan <- startSpellCheckerThread tId eventQueue spellCheckerTimeout let resetSCTimer = STM.atomically $ STM.writeTChan resetSCChan () return $ Just (as, resetSCTimer) @@ -201,13 +201,14 @@ -- The worker thread works by reading a timer from its queue, waiting -- until the timer expires, and then injecting an event into the main -- event loop to request a spell check. -startSpellCheckerThread :: BChan MHEvent +startSpellCheckerThread :: TeamId + -> BChan MHEvent -- ^ The main event loop's event channel. -> Int -- ^ The number of microseconds to wait before -- requesting a spell check. -> IO (STM.TChan ()) -startSpellCheckerThread eventChan spellCheckTimeout = do +startSpellCheckerThread tId eventChan spellCheckTimeout = do delayWakeupChan <- STM.atomically STM.newTChan delayWorkerChan <- STM.atomically STM.newTChan delVar <- STM.atomically $ STM.newTVar Nothing @@ -216,7 +217,7 @@ -- requests a spell check. void $ forkIO $ forever $ do STM.atomically $ waitDelay =<< STM.readTChan delayWorkerChan - writeBChan eventChan (RespEvent requestSpellCheck) + writeBChan eventChan (RespEvent $ requestSpellCheck tId) -- The delay manager waits for requests to start a delay timer and -- signals the worker to begin waiting. diff --git a/src/Matterhorn/State/Teams.hs b/src/Matterhorn/State/Teams.hs --- a/src/Matterhorn/State/Teams.hs +++ b/src/Matterhorn/State/Teams.hs @@ -14,7 +14,7 @@ import Prelude () import Matterhorn.Prelude -import Brick.Main ( invalidateCache, hScrollToBeginning, viewportScroll ) +import Brick.Main ( invalidateCache, hScrollToBeginning, viewportScroll, makeVisible ) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Time.Clock ( getCurrentTime ) @@ -63,14 +63,16 @@ updateViewed True csTeamZipper %= f - postChangeTeamCommon + withCurrentTeam postChangeTeamCommon -- | Book-keeping common to all team selection changes. -postChangeTeamCommon :: MH () -postChangeTeamCommon = do +postChangeTeamCommon :: TeamId -> MH () +postChangeTeamCommon tId = do updateViewed False - fetchVisibleIfNeeded - mh $ hScrollToBeginning (viewportScroll TeamList) + fetchVisibleIfNeeded tId + mh $ do + hScrollToBeginning (viewportScroll TeamList) + makeVisible $ SelectedChannelListEntry tId -- | Fetch the specified team and add it to the application state. -- @@ -81,19 +83,19 @@ session <- getSession cr <- use csResources me <- use csMe + curTs <- use csTeams + let myTIds = HM.keys curTs - mhLog LogGeneral $ T.pack $ "Joining team " <> show tId - doAsyncWith Normal $ do - t <- MM.mmGetTeam tId session - (ts, chans) <- buildTeamState cr me t - return $ Just $ do - curTs <- use csTeams - let myTIds = HM.keys curTs - when (not $ tId `elem` myTIds) $ do - addTeamState ts chans - updateSidebar $ Just tId - updateWindowTitle - refreshTeamZipper + when (not $ tId `elem` myTIds) $ do + mhLog LogGeneral $ T.pack $ "Joining team " <> show tId + doAsyncWith Normal $ do + t <- MM.mmGetTeam tId session + (ts, chans) <- buildTeamState cr me t + return $ Just $ do + addTeamState ts chans + updateSidebar $ Just tId + updateWindowTitle + refreshTeamZipper -- | Remove the specified team to the application state. -- @@ -129,14 +131,14 @@ -- | Set the team zipper ordering with the specified transformation, -- which is expected to be either 'moveLeft' or 'moveRight'. setTeamOrderWith :: (TeamId -> [TeamId] -> [TeamId]) -> MH () -setTeamOrderWith sortFunc = do +setTeamOrderWith transform = do session <- getSession me <- use csMe - tId <- use csCurrentTeamId + mtId <- use csCurrentTeamId z <- use csTeamZipper let tIds = teamZipperIds z - newList = sortFunc tId tIds + newList = maybe tIds (\tId -> transform tId tIds) mtId doAsyncWith Normal $ do let pref = teamOrderPref (me^.userIdL) newList @@ -165,6 +167,7 @@ buildTeamState cr me team = do let tId = teamId team session = getResourceSession cr + config = cr^.crConfiguration -- Create a predicate to find the last selected channel by reading -- the run state file. If unable to read or decode or validate the @@ -173,7 +176,7 @@ result <- readLastRunState tId case result of Right lrs | isValidLastRunState cr me lrs -> return $ \c -> - channelId c == lrs^.lrsSelectedChannelId + Just (channelId c) == lrs^.lrsSelectedChannelId _ -> return isTownSquare -- Get all channels, but filter down to just the one we want @@ -195,16 +198,16 @@ return (getId c, cChannel) -- Start the spell checker and spell check timer, if configured - spResult <- maybeStartSpellChecker (cr^.crConfiguration) (cr^.crEventQueue) + spResult <- maybeStartSpellChecker tId config (cr^.crEventQueue) now <- getCurrentTime - let chanIds = mkChannelZipperList now (cr^.crConfiguration) tId + let chanIds = mkChannelZipperList (config^.configChannelListSortingL) now config tId Nothing (cr^.crUserPreferences) - clientChans noUsers + mempty clientChans noUsers chanZip = Z.fromList chanIds clientChans = foldr (uncurry addChannel) noChannels chanPairs - return (newTeamState team chanZip spResult, clientChans) + return (newTeamState config team chanZip spResult, clientChans) -- | Add a new 'TeamState' and corresponding channels to the application -- state. diff --git a/src/Matterhorn/State/ThemeListOverlay.hs b/src/Matterhorn/State/ThemeListOverlay.hs --- a/src/Matterhorn/State/ThemeListOverlay.hs +++ b/src/Matterhorn/State/ThemeListOverlay.hs @@ -29,34 +29,34 @@ -- | Show the user list overlay with the given search scope, and issue a -- request to gather the first search results. -enterThemeListMode :: MH () -enterThemeListMode = - enterListOverlayMode (csCurrentTeam.tsThemeListOverlay) - ThemeListOverlay () setInternalTheme getThemesMatching +enterThemeListMode :: TeamId -> MH () +enterThemeListMode tId = + enterListOverlayMode tId (csTeam(tId).tsThemeListOverlay) + ThemeListOverlay () (setInternalTheme tId) getThemesMatching -- | Move the selection up in the user list overlay by one user. -themeListSelectUp :: MH () -themeListSelectUp = themeListMove L.listMoveUp +themeListSelectUp :: TeamId -> MH () +themeListSelectUp tId = themeListMove tId L.listMoveUp -- | Move the selection down in the user list overlay by one user. -themeListSelectDown :: MH () -themeListSelectDown = themeListMove L.listMoveDown +themeListSelectDown :: TeamId -> MH () +themeListSelectDown tId = themeListMove tId L.listMoveDown -- | Move the selection up in the user list overlay by a page of users -- (themeListPageSize). -themeListPageUp :: MH () -themeListPageUp = themeListMove (L.listMoveBy (-1 * themeListPageSize)) +themeListPageUp :: TeamId -> MH () +themeListPageUp tId = themeListMove tId (L.listMoveBy (-1 * themeListPageSize)) -- | Move the selection down in the user list overlay by a page of users -- (themeListPageSize). -themeListPageDown :: MH () -themeListPageDown = themeListMove (L.listMoveBy themeListPageSize) +themeListPageDown :: TeamId -> MH () +themeListPageDown tId = themeListMove tId (L.listMoveBy themeListPageSize) -- | Transform the user list results in some way, e.g. by moving the -- cursor, and then check to see whether the modification warrants a -- prefetch of more search results. -themeListMove :: (L.List Name InternalTheme -> L.List Name InternalTheme) -> MH () -themeListMove = listOverlayMove (csCurrentTeam.tsThemeListOverlay) +themeListMove :: TeamId -> (L.List Name InternalTheme -> L.List Name InternalTheme) -> MH () +themeListMove tId = listOverlayMove (csTeam(tId).tsThemeListOverlay) -- | The number of users in a "page" for cursor movement purposes. themeListPageSize :: Int @@ -73,15 +73,15 @@ search `T.isInfixOf` T.toLower (internalThemeDesc t) return $ Vec.fromList matching -setInternalTheme :: InternalTheme -> MH Bool -setInternalTheme t = do - setTheme $ internalThemeName t +setInternalTheme :: TeamId -> InternalTheme -> MH Bool +setInternalTheme tId t = do + setTheme tId $ internalThemeName t return False -setTheme :: Text -> MH () -setTheme name = +setTheme :: TeamId -> Text -> MH () +setTheme tId name = case lookupTheme name of - Nothing -> enterThemeListMode + Nothing -> enterThemeListMode tId Just it -> do mh invalidateCache csResources.crTheme .= (themeToAttrMap $ internalTheme it) diff --git a/src/Matterhorn/State/UrlSelect.hs b/src/Matterhorn/State/UrlSelect.hs --- a/src/Matterhorn/State/UrlSelect.hs +++ b/src/Matterhorn/State/UrlSelect.hs @@ -14,29 +14,32 @@ import qualified Data.Vector as V import Lens.Micro.Platform ( (.=), to ) +import Network.Mattermost.Types ( TeamId ) + import Matterhorn.State.Links import Matterhorn.Types import Matterhorn.Util -startUrlSelect :: MH () -startUrlSelect = do - urls <- use (csCurrentChannel.to findUrls.to V.fromList) - let urlsWithIndexes = V.indexed urls - tId <- use csCurrentTeamId - setMode UrlSelect - csCurrentTeam.tsUrlList .= (listMoveTo (length urls - 1) $ list (UrlList tId) urlsWithIndexes 2) +startUrlSelect :: TeamId -> MH () +startUrlSelect tId = do + withCurrentChannel tId $ \_ chan -> do + let urls = V.fromList $ findUrls chan + urlsWithIndexes = V.indexed urls + setMode tId UrlSelect + csTeam(tId).tsUrlList .= (listMoveTo (length urls - 1) $ list (UrlList tId) urlsWithIndexes 2) -stopUrlSelect :: MH () -stopUrlSelect = setMode Main +stopUrlSelect :: TeamId -> MH () +stopUrlSelect tId = do + setMode tId Main -openSelectedURL :: MH () -openSelectedURL = whenMode UrlSelect $ do - selected <- use (csCurrentTeam.tsUrlList.to listSelectedElement) +openSelectedURL :: TeamId -> MH () +openSelectedURL tId = whenMode tId UrlSelect $ do + selected <- use (csTeam(tId).tsUrlList.to listSelectedElement) case selected of Nothing -> return () Just (_, (_, link)) -> openLinkTarget (link^.linkTarget) - setMode Main + setMode tId Main findUrls :: ClientChannel -> [LinkChoice] findUrls chan = diff --git a/src/Matterhorn/State/UserListOverlay.hs b/src/Matterhorn/State/UserListOverlay.hs --- a/src/Matterhorn/State/UserListOverlay.hs +++ b/src/Matterhorn/State/UserListOverlay.hs @@ -32,49 +32,46 @@ -- | Show the user list overlay for searching/showing members of the -- current channel. -enterChannelMembersUserList :: MH () -enterChannelMembersUserList = do - myTId <- use csCurrentTeamId - cId <- use (csCurrentChannelId myTId) - myId <- gets myUserId - session <- getSession +enterChannelMembersUserList :: TeamId -> MH () +enterChannelMembersUserList myTId = do + withCurrentChannel myTId $ \cId _ -> do + myId <- gets myUserId + session <- getSession - doAsyncWith Preempt $ do - stats <- MM.mmGetChannelStatistics cId session - return $ Just $ do - enterUserListMode myTId (ChannelMembers cId myTId) (Just $ channelStatsMemberCount stats) - (\u -> case u^.uiId /= myId of - True -> createOrFocusDMChannel u Nothing >> return True - False -> return False - ) + doAsyncWith Preempt $ do + stats <- MM.mmGetChannelStatistics cId session + return $ Just $ do + enterUserListMode myTId (ChannelMembers cId myTId) (Just $ channelStatsMemberCount stats) + (\u -> case u^.uiId /= myId of + True -> createOrFocusDMChannel myTId u Nothing >> return True + False -> return False + ) -- | Show the user list overlay for showing users that are not members -- of the current channel for the purpose of adding them to the -- channel. -enterChannelInviteUserList :: MH () -enterChannelInviteUserList = do - myTId <- use csCurrentTeamId - cId <- use (csCurrentChannelId myTId) - myId <- gets myUserId - enterUserListMode myTId (ChannelNonMembers cId myTId) Nothing - (\u -> case u^.uiId /= myId of - True -> addUserToCurrentChannel u >> return True - False -> return False - ) +enterChannelInviteUserList :: TeamId -> MH () +enterChannelInviteUserList myTId = do + withCurrentChannel myTId $ \cId _ -> do + myId <- gets myUserId + enterUserListMode myTId (ChannelNonMembers cId myTId) Nothing + (\u -> case u^.uiId /= myId of + True -> addUserToCurrentChannel myTId u >> return True + False -> return False + ) -- | Show the user list overlay for showing all users for the purpose of -- starting a direct message channel with another user. -enterDMSearchUserList :: MH () -enterDMSearchUserList = do +enterDMSearchUserList :: TeamId -> MH () +enterDMSearchUserList myTId = do myId <- gets myUserId - myTId <- use csCurrentTeamId config <- use csClientConfig let restrictTeam = case MM.clientConfigRestrictDirectMessage <$> config of Just MM.RestrictTeam -> Just myTId _ -> Nothing enterUserListMode myTId (AllUsers restrictTeam) Nothing (\u -> case u^.uiId /= myId of - True -> createOrFocusDMChannel u Nothing >> return True + True -> createOrFocusDMChannel myTId u Nothing >> return True False -> return False ) @@ -83,35 +80,35 @@ enterUserListMode :: TeamId -> UserSearchScope -> Maybe Int -> (UserInfo -> MH Bool) -> MH () enterUserListMode tId scope resultCount enterHandler = do csTeam(tId).tsUserListOverlay.listOverlayRecordCount .= resultCount - enterListOverlayMode (csTeam(tId).tsUserListOverlay) UserListOverlay scope enterHandler getUserSearchResults + enterListOverlayMode tId (csTeam(tId).tsUserListOverlay) UserListOverlay scope enterHandler getUserSearchResults userInfoFromPair :: User -> Text -> UserInfo userInfoFromPair u status = userInfoFromUser u True & uiStatus .~ statusFromText status -- | Move the selection up in the user list overlay by one user. -userListSelectUp :: MH () -userListSelectUp = userListMove L.listMoveUp +userListSelectUp :: TeamId -> MH () +userListSelectUp tId = userListMove tId L.listMoveUp -- | Move the selection down in the user list overlay by one user. -userListSelectDown :: MH () -userListSelectDown = userListMove L.listMoveDown +userListSelectDown :: TeamId -> MH () +userListSelectDown tId = userListMove tId L.listMoveDown -- | Move the selection up in the user list overlay by a page of users -- (userListPageSize). -userListPageUp :: MH () -userListPageUp = userListMove (L.listMoveBy (-1 * userListPageSize)) +userListPageUp :: TeamId -> MH () +userListPageUp tId = userListMove tId (L.listMoveBy (-1 * userListPageSize)) -- | Move the selection down in the user list overlay by a page of users -- (userListPageSize). -userListPageDown :: MH () -userListPageDown = userListMove (L.listMoveBy userListPageSize) +userListPageDown :: TeamId -> MH () +userListPageDown tId = userListMove tId (L.listMoveBy userListPageSize) -- | Transform the user list results in some way, e.g. by moving the -- cursor, and then check to see whether the modification warrants a -- prefetch of more search results. -userListMove :: (L.List Name UserInfo -> L.List Name UserInfo) -> MH () -userListMove = listOverlayMove (csCurrentTeam.tsUserListOverlay) +userListMove :: TeamId -> (L.List Name UserInfo -> L.List Name UserInfo) -> MH () +userListMove tId = listOverlayMove (csTeam(tId).tsUserListOverlay) -- | The number of users in a "page" for cursor movement purposes. userListPageSize :: Int diff --git a/src/Matterhorn/Themes.hs b/src/Matterhorn/Themes.hs --- a/src/Matterhorn/Themes.hs +++ b/src/Matterhorn/Themes.hs @@ -290,6 +290,9 @@ , (currentUserAttr, defAttr `withStyle` bold) , (channelHeaderAttr, fg black) , (verbatimTruncateMessageAttr, fg blue) + , (scrollbarAttr, defAttr) + , (scrollbarHandleAttr, defAttr `withStyle` reverseVideo) + , (scrollbarTroughAttr, defAttr) , (channelListHeaderAttr, fg cyan) , (currentChannelNameAttr, black `on` yellow `withStyle` bold) , (unreadChannelAttr, black `on` cyan `withStyle` bold) @@ -360,6 +363,9 @@ , (unreadChannelAttr, black `on` cyan `withStyle` bold) , (unreadGroupMarkerAttr, fg white `withStyle` bold) , (mentionsChannelAttr, black `on` brightMagenta `withStyle` bold) + , (scrollbarAttr, defAttr) + , (scrollbarHandleAttr, defAttr `withStyle` reverseVideo) + , (scrollbarTroughAttr, defAttr) , (urlAttr, fg yellow) , (emailAttr, fg yellow) , (codeAttr, fg magenta) @@ -847,6 +853,15 @@ ) , ( verbatimTruncateMessageAttr , "Attribute for a message indicating that a verbatim or code block has been only partially displayed" + ) + , ( scrollbarAttr + , "Base aAttribute for scroll bars" + ) + , ( scrollbarTroughAttr + , "Attribute for scroll bar troughs" + ) + , ( scrollbarHandleAttr + , "Attribute for scroll bar handles" ) ] <> [ (usernameAttr i, T.pack $ "Username color " <> show i) | i <- [0..usernameColorHashBuckets-1] diff --git a/src/Matterhorn/Types.hs b/src/Matterhorn/Types.hs --- a/src/Matterhorn/Types.hs +++ b/src/Matterhorn/Types.hs @@ -38,6 +38,7 @@ , clearChannelUnreadStatus , ChannelListEntry(..) , ChannelListEntryType(..) + , ChannelListSorting(..) , ChannelListOrientation(..) , channelListEntryUserId , userIdsFromZipper @@ -46,6 +47,7 @@ , ciPort , ciUrlPath , ciUsername + , ciOTPToken , ciPassword , ciType , ciAccessToken @@ -81,6 +83,7 @@ , configActivityNotifyVersionL , configActivityBellL , configTruncateVerbatimBlocksL + , configChannelListSortingL , configShowMessageTimestampsL , configShowBackgroundL , configShowMessagePreviewL @@ -94,6 +97,7 @@ , configLogMaxBufferSizeL , configShowOlderEditsL , configShowTypingIndicatorL + , configSendTypingNotificationsL , configAbsPathL , configUserKeysL , configHyperlinkingModeL @@ -122,6 +126,7 @@ , attrNameToConfig , sortTeams + , matchesTeam , mkTeamZipper , mkTeamZipperFromIds , teamZipperIds @@ -129,6 +134,7 @@ , ChannelListGroup(..) , ChannelListGroupLabel(..) , nonDMChannelListGroupUnread + , channelListGroupNames , trimChannelSigil @@ -157,24 +163,28 @@ , tsReactionEmojiListOverlay , tsThemeListOverlay , tsSaveAttachmentDialog + , tsChannelListSorting , ChatState , newState , newTeamState + , withCurrentChannel + , withCurrentChannel' + , withCurrentTeam + , csTeamZipper - , csCurrentTeam , csTeams , csTeam , csChannelListOrientation , csResources , csLastMouseDownEvent , csVerbatimTruncateSetting - , csCurrentChannel , csCurrentChannelId , csCurrentTeamId , csPostMap , csUsers + , csHiddenChannelGroups , csConnectionStatus , csWorkerIsBusy , csChannel @@ -388,6 +398,7 @@ import qualified Data.Foldable as F import Data.Function ( on ) import qualified Data.Kind as K +import Data.Maybe ( fromJust ) import Data.Ord ( comparing ) import qualified Data.HashMap.Strict as HM import Data.List ( sortBy, nub, elemIndex, partition ) @@ -397,9 +408,8 @@ import Data.Time.Clock ( getCurrentTime, addUTCTime ) import Data.UUID ( UUID ) import qualified Data.Vector as Vec -import Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=) - , (%=), (^?), (.~) - , _Just, Traversal', preuse, to +import Lens.Micro.Platform ( at, makeLenses, lens, (^?!), (.=) + , (%=), (.~), _Just, Traversal', to , SimpleGetter ) import Network.Connection ( HostNotResolved, HostCannotConnect ) @@ -455,16 +465,26 @@ data ChannelListGroup = ChannelListGroup { channelListGroupLabel :: ChannelListGroupLabel , channelListGroupUnread :: Int + , channelListGroupCollapsed :: Bool + , channelListGroupEntries :: Int } - deriving (Eq) + deriving (Eq, Show) data ChannelListGroupLabel = ChannelGroupPublicChannels | ChannelGroupPrivateChannels | ChannelGroupFavoriteChannels | ChannelGroupDirectMessages - deriving (Eq) + deriving (Eq, Ord, Show) +channelListGroupNames :: [(T.Text, ChannelListGroupLabel)] +channelListGroupNames = + [ ("public", ChannelGroupPublicChannels) + , ("private", ChannelGroupPrivateChannels) + , ("favorite", ChannelGroupFavoriteChannels) + , ("direct", ChannelGroupDirectMessages) + ] + nonDMChannelListGroupUnread :: ChannelListGroup -> Int nonDMChannelListGroupUnread g = case channelListGroupLabel g of @@ -491,6 +511,11 @@ -- ^ A multi-user DM entry deriving (Eq, Show, Ord) +data ChannelListSorting = + ChannelListSortDefault + | ChannelListSortUnreadFirst + deriving (Eq, Show, Ord) + -- | 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. @@ -561,9 +586,13 @@ , configShowOlderEdits :: Bool -- ^ Whether to highlight the edit indicator on edits made -- prior to the beginning of the current session. + , configChannelListSorting :: ChannelListSorting + -- ^ How to sort channels in each channel list group , configShowTypingIndicator :: Bool - -- ^ Whether to show the typing indicator for other users, - -- and whether to send typing notifications to other users. + -- ^ Whether to show the typing indicator when other users + -- are typing + , configSendTypingNotifications :: Bool + -- Whether to send typing notifications to other users. , configAbsPath :: Maybe FilePath -- ^ A book-keeping field for the absolute path to the -- configuration. (Not a user setting.) @@ -630,31 +659,53 @@ (((_cdUpdated info) > lastViewTime) || (isJust $ _cdEditedMessageThreshold info))) -mkChannelZipperList :: UTCTime +mkChannelZipperList :: ChannelListSorting + -> UTCTime -> Config -> TeamId -> Maybe ClientConfig -> UserPreferences + -> HM.HashMap TeamId (Set ChannelListGroupLabel) -> ClientChannels -> Users -> [(ChannelListGroup, [ChannelListEntry])] -mkChannelZipperList now config tId cconfig prefs cs us = +mkChannelZipperList sorting now config tId cconfig prefs hidden cs us = let (privFavs, privEntries) = partitionFavorites $ getChannelEntriesByType tId prefs cs Private (normFavs, normEntries) = partitionFavorites $ getChannelEntriesByType tId prefs cs Ordinary (dmFavs, dmEntries) = partitionFavorites $ getDMChannelEntries now config cconfig prefs us cs favEntries = privFavs <> normFavs <> dmFavs + isHidden label = + case HM.lookup tId hidden of + Nothing -> False + Just s -> Set.member label s in [ let unread = length $ filter channelListEntryUnread favEntries - in (ChannelListGroup ChannelGroupFavoriteChannels unread, sortChannelListEntries favEntries) + coll = isHidden ChannelGroupFavoriteChannels + in ( ChannelListGroup ChannelGroupFavoriteChannels unread coll (length favEntries) + , if coll then mempty else sortChannelListEntries sorting favEntries + ) , let unread = length $ filter channelListEntryUnread normEntries - in (ChannelListGroup ChannelGroupPublicChannels unread, sortChannelListEntries normEntries) + coll = isHidden ChannelGroupPublicChannels + in ( ChannelListGroup ChannelGroupPublicChannels unread coll (length normEntries) + , if coll then mempty else sortChannelListEntries sorting normEntries + ) , let unread = length $ filter channelListEntryUnread privEntries - in (ChannelListGroup ChannelGroupPrivateChannels unread, sortChannelListEntries privEntries) + coll = isHidden ChannelGroupPrivateChannels + in ( ChannelListGroup ChannelGroupPrivateChannels unread coll (length privEntries) + , if coll then mempty else sortChannelListEntries sorting privEntries + ) , let unread = length $ filter channelListEntryUnread dmEntries - in (ChannelListGroup ChannelGroupDirectMessages unread, sortDMChannelListEntries dmEntries) + coll = isHidden ChannelGroupDirectMessages + in ( ChannelListGroup ChannelGroupDirectMessages unread coll (length dmEntries) + , if coll then mempty else sortDMChannelListEntries dmEntries + ) ] -sortChannelListEntries :: [ChannelListEntry] -> [ChannelListEntry] -sortChannelListEntries = sortBy (comparing (\c -> (channelListEntryMuted c, channelListEntrySortValue c))) +sortChannelListEntries :: ChannelListSorting -> [ChannelListEntry] -> [ChannelListEntry] +sortChannelListEntries ChannelListSortDefault = + sortBy (comparing (\c -> (channelListEntryMuted c, channelListEntrySortValue c))) +sortChannelListEntries ChannelListSortUnreadFirst = + sortBy (comparing (not . channelListEntryUnread)) . + sortChannelListEntries ChannelListSortDefault sortDMChannelListEntries :: [ChannelListEntry] -> [ChannelListEntry] sortDMChannelListEntries = sortBy compareDMChannelListEntries @@ -781,7 +832,7 @@ localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now cutoff = ServerTime localCutoff updated = c^.ccInfo.cdUpdated - Just uId = c^.ccInfo.cdDMUserId + uId = fromJust $ c^.ccInfo.cdDMUserId cId = c^.ccInfo.cdChannelId in if isFavorite prefs cId then True @@ -873,7 +924,7 @@ | ChannelTopicSaveButton TeamId | ChannelTopicCancelButton TeamId | ChannelTopicEditorPreview TeamId - | ChannelTopic + | ChannelTopic ChannelId | TeamList | ClickableChannelListEntry ChannelId | ClickableTeamListEntry TeamId @@ -885,11 +936,14 @@ | ClickableReactionInMessage PostId Text (Set UserId) | ClickableReaction PostId Text (Set UserId) | ClickableAttachment FileId + | ClickableChannelListGroupHeading ChannelListGroupLabel | AttachmentPathEditor TeamId | AttachmentPathSaveButton TeamId | AttachmentPathCancelButton TeamId | RenderedMessage MessageId | ReactionEmojiListOverlayEntry (Bool, T.Text) + | SelectedChannelListEntry TeamId + | VScrollBar Brick.ClickableScrollbarElement Name deriving (Eq, Show, Ord) -- | Types that provide a "semantically equal" operation. Two values may @@ -933,6 +987,7 @@ , _ciPort :: Int , _ciUrlPath :: Text , _ciUsername :: Text + , _ciOTPToken :: Maybe Text , _ciPassword :: Text , _ciAccessToken :: Text , _ciType :: ConnectionType @@ -1290,7 +1345,7 @@ | ThemeHelp | SyntaxHighlightHelp | KeybindingHelp - deriving (Eq) + deriving (Eq, Show) -- | Help topics data HelpTopic = @@ -1299,14 +1354,14 @@ , helpTopicScreen :: HelpScreen , helpTopicViewportName :: Name } - deriving (Eq) + deriving (Eq, Show) -- | Mode type for the current contents of the post list overlay data PostListContents = PostListFlagged | PostListPinned ChannelId | PostListSearch Text Bool -- for the query and search status - deriving (Eq) + deriving (Eq, Show) -- | The 'Mode' represents the current dominant UI activity data Mode = @@ -1329,7 +1384,7 @@ | EditNotifyPrefs | ChannelTopicWindow | SaveAttachmentWindow LinkChoice - deriving (Eq) + deriving (Eq, Show) -- | We're either connected or we're not. data ConnectionStatus = Connected | Disconnected deriving (Eq) @@ -1536,6 +1591,9 @@ , _csChannels :: ClientChannels -- ^ The channels that we are showing, including their -- message lists. + , _csHiddenChannelGroups :: HM.HashMap TeamId (Set ChannelListGroupLabel) + -- ^ The set of channel list groups that are currently + -- collapsed in the sidebar. , _csPostMap :: HashMap PostId Message -- ^ The map of post IDs to messages. This allows us to -- access messages by ID without having to linearly scan @@ -1631,6 +1689,9 @@ , _tsSaveAttachmentDialog :: SaveAttachmentDialogState -- ^ The state for the interactive attachment-saving -- editor window. + , _tsChannelListSorting :: ChannelListSorting + -- ^ How to sort channels in this team's channel list + -- groups } -- | Handles for the View Message window's tabs. @@ -1675,6 +1736,14 @@ sortTeams :: [Team] -> [Team] sortTeams = sortBy (compare `on` (T.strip . sanitizeUserText . teamName)) +matchesTeam :: T.Text -> Team -> Bool +matchesTeam tName t = + let normalizeUserText = normalize . sanitizeUserText + normalize = T.strip . T.toLower + urlName = normalizeUserText $ teamName t + displayName = normalizeUserText $ teamDisplayName t + in normalize tName `elem` [displayName, urlName] + mkTeamZipper :: HM.HashMap TeamId TeamState -> Z.Zipper () TeamId mkTeamZipper m = let sortedTeams = sortTeams $ _tsTeam <$> HM.elems m @@ -1686,11 +1755,12 @@ teamZipperIds :: Z.Zipper () TeamId -> [TeamId] teamZipperIds = concat . fmap snd . Z.toList -newTeamState :: Team +newTeamState :: Config + -> Team -> Z.Zipper ChannelListGroup ChannelListEntry -> Maybe (Aspell, IO ()) -> TeamState -newTeamState team chanList spellChecker = +newTeamState config team chanList spellChecker = let tId = teamId team in TeamState { _tsMode = Main , _tsFocus = chanList @@ -1711,6 +1781,7 @@ , _tsThemeListOverlay = nullThemeListOverlayState tId , _tsReactionEmojiListOverlay = nullEmojiListOverlayState tId , _tsSaveAttachmentDialog = newSaveAttachmentDialog tId "" + , _tsChannelListSorting = configChannelListSorting config } -- | Make a new channel topic editor window state. @@ -2013,7 +2084,7 @@ fail = MH . MHF.fail instance Monad MH where - return x = MH (return x) + return = pure MH x >>= f = MH (x >>= \ x' -> fromMH (f x')) -- We want to pretend that the state is only the ChatState, rather @@ -2130,7 +2201,7 @@ unmentioned = filter (not . wasMentioned) $ HM.elems teams wasMentioned ts = (teamId $ _tsTeam ts) `elem` tIds zipperTids = tIds <> (teamId <$> sortTeams (_tsTeam <$> unmentioned)) - in st { _csTeamZipper = (Z.findRight (== curTId) $ mkTeamZipperFromIds zipperTids) + in st { _csTeamZipper = (Z.findRight ((== curTId) . Just) $ mkTeamZipperFromIds zipperTids) } refreshTeamZipper :: MH () @@ -2161,6 +2232,7 @@ , _csWorkerIsBusy = Nothing , _csClientConfig = Nothing , _csInputHistory = startupStateInitialHistory + , _csHiddenChannelGroups = mempty } getServerBaseUrl :: TeamId -> MH TeamBaseURL @@ -2185,18 +2257,18 @@ getResourceSession :: ChatResources -> Session getResourceSession = _crSession -whenMode :: Mode -> MH () -> MH () -whenMode m act = do - curMode <- use (csCurrentTeam.tsMode) +whenMode :: TeamId -> Mode -> MH () -> MH () +whenMode tId m act = do + curMode <- use (csTeam(tId).tsMode) when (curMode == m) act -setMode :: Mode -> MH () -setMode m = do - csCurrentTeam.tsMode .= m +setMode :: TeamId -> Mode -> MH () +setMode tId m = do + csTeam(tId).tsMode .= m mh invalidateCache -setMode' :: Mode -> ChatState -> ChatState -setMode' m = csCurrentTeam.tsMode .~ m +setMode' :: TeamId -> Mode -> ChatState -> ChatState +setMode' tId m = csTeam(tId).tsMode .~ m resetSpellCheckTimer :: ChatEditState -> IO () resetSpellCheckTimer s = @@ -2205,19 +2277,42 @@ Just (_, reset) -> reset -- ** Utility Lenses -csCurrentChannelId :: TeamId -> SimpleGetter ChatState ChannelId +csCurrentChannelId :: TeamId -> SimpleGetter ChatState (Maybe ChannelId) csCurrentChannelId tId = - csTeam(tId).tsFocus.to Z.unsafeFocus.to channelListEntryChannelId + csTeam(tId).tsFocus.to Z.focus.to (fmap channelListEntryChannelId) -csCurrentTeamId :: SimpleGetter ChatState TeamId -csCurrentTeamId = - csTeamZipper.to Z.unsafeFocus +withCurrentTeam :: (TeamId -> MH ()) -> MH () +withCurrentTeam f = do + mtId <- use csCurrentTeamId + case mtId of + Nothing -> return () + Just tId -> f tId -csCurrentTeam :: Lens' ChatState TeamState -csCurrentTeam = - lens (\st -> st^.csTeam(st^.csCurrentTeamId)) - (\st t -> st & csTeam(st^.csCurrentTeamId) .~ t) +withCurrentChannel :: TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH () +withCurrentChannel tId f = do + mcId <- use $ csCurrentChannelId tId + case mcId of + Nothing -> return () + Just cId -> do + mChan <- preuse $ csChannel cId + case mChan of + Just ch -> f cId ch + _ -> return () +withCurrentChannel' :: TeamId -> (ChannelId -> ClientChannel -> MH (Maybe a)) -> MH (Maybe a) +withCurrentChannel' tId f = do + mcId <- use $ csCurrentChannelId tId + case mcId of + Nothing -> return Nothing + Just cId -> do + mChan <- preuse $ csChannel cId + case mChan of + Just ch -> f cId ch + _ -> return Nothing + +csCurrentTeamId :: SimpleGetter ChatState (Maybe TeamId) +csCurrentTeamId = csTeamZipper.to Z.focus + csTeam :: TeamId -> Lens' ChatState TeamState csTeam tId = lens (\ st -> st ^. csTeams . at tId ^?! _Just) @@ -2240,11 +2335,6 @@ CLGroupDM {} -> True CLChannel {} -> False -csCurrentChannel :: Lens' ChatState ClientChannel -csCurrentChannel = - lens (\ st -> findChannelById (st^.csCurrentChannelId(st^.csCurrentTeamId)) (st^.csChannels) ^?! _Just) - (\ st n -> st & csChannels %~ addChannel (st^.csCurrentChannelId(st^.csCurrentTeamId)) n) - csChannel :: ChannelId -> Traversal' ChatState ClientChannel csChannel cId = csChannels . channelByIdL cId @@ -2336,10 +2426,10 @@ userIdForUsername name st = fst <$> (findUserByUsername name $ st^.csUsers) -channelIdByChannelName :: Text -> ChatState -> Maybe ChannelId -channelIdByChannelName name st = +channelIdByChannelName :: TeamId -> Text -> ChatState -> Maybe ChannelId +channelIdByChannelName tId name st = let matches (_, cc) = cc^.ccInfo.cdName == (trimChannelSigil name) && - cc^.ccInfo.cdTeamId == (Just $ st^.csCurrentTeamId) + cc^.ccInfo.cdTeamId == (Just tId) in listToMaybe $ fst <$> filteredChannels matches (st^.csChannels) channelIdByUsername :: Text -> ChatState -> Maybe ChannelId @@ -2369,10 +2459,10 @@ deriving (Eq, Show) -resetAutocomplete :: MH () -resetAutocomplete = do - csCurrentTeam.tsEditState.cedAutocomplete .= Nothing - csCurrentTeam.tsEditState.cedAutocompletePending .= Nothing +resetAutocomplete :: TeamId -> MH () +resetAutocomplete tId = do + csTeam(tId).tsEditState.cedAutocomplete .= Nothing + csTeam(tId).tsEditState.cedAutocompletePending .= Nothing -- * Slash Commands @@ -2464,13 +2554,12 @@ emptyHSet :: HighlightSet emptyHSet = HighlightSet Set.empty Set.empty mempty -getHighlightSet :: ChatState -> HighlightSet -getHighlightSet st = - let tId = st^.csCurrentTeamId - in HighlightSet { hUserSet = addSpecialUserMentions $ getUsernameSet $ st^.csUsers - , hChannelSet = getChannelNameSet tId $ st^.csChannels - , hSyntaxMap = st^.csResources.crSyntaxMap - } +getHighlightSet :: ChatState -> TeamId -> HighlightSet +getHighlightSet st tId = + HighlightSet { hUserSet = addSpecialUserMentions $ getUsernameSet $ st^.csUsers + , hChannelSet = getChannelNameSet tId $ st^.csChannels + , hSyntaxMap = st^.csResources.crSyntaxMap + } attrNameToConfig :: Brick.AttrName -> Text attrNameToConfig = T.pack . intercalate "." . Brick.attrNameComponents diff --git a/src/Matterhorn/Types/Channels.hs b/src/Matterhorn/Types/Channels.hs --- a/src/Matterhorn/Types/Channels.hs +++ b/src/Matterhorn/Types/Channels.hs @@ -285,19 +285,18 @@ -- ** Manage the collection of all Channels --- | Define a binary kinded type to allow derivation of functor. -data AllMyChannels a = - AllChannels { _chanMap :: HashMap ChannelId a - , _channelNameSet :: HashMap TeamId (S.Set Text) - , _userChannelMap :: HashMap UserId ChannelId - } - deriving (Functor, Foldable, Traversable) +data ChannelCollection a = + ChannelCollection { _chanMap :: HashMap ChannelId a + , _channelNameSet :: HashMap TeamId (S.Set Text) + , _userChannelMap :: HashMap UserId ChannelId + } + deriving (Functor, Foldable, Traversable) -- | Define the exported typename which universally binds the -- collection to the ChannelInfo type. -type ClientChannels = AllMyChannels ClientChannel +type ClientChannels = ChannelCollection ClientChannel -makeLenses ''AllMyChannels +makeLenses ''ChannelCollection getChannelNameSet :: TeamId -> ClientChannels -> S.Set Text getChannelNameSet tId cs = case cs^.channelNameSet.at tId of @@ -306,7 +305,11 @@ -- | Initial collection of Channels with no members noChannels :: ClientChannels -noChannels = AllChannels HM.empty HM.empty HM.empty +noChannels = + ChannelCollection { _chanMap = HM.empty + , _channelNameSet = HM.empty + , _userChannelMap = HM.empty + } -- | Add a channel to the existing collection. addChannel :: ChannelId -> ClientChannel -> ClientChannels -> ClientChannels @@ -335,12 +338,12 @@ & removeChannelName & userChannelMap %~ HM.filter (/= cId) -instance Semigroup (AllMyChannels ClientChannel) where +instance Semigroup (ChannelCollection ClientChannel) where a <> b = let pairs = HM.toList $ _chanMap a in foldr (uncurry addChannel) b pairs -instance Monoid (AllMyChannels ClientChannel) where +instance Monoid (ChannelCollection ClientChannel) where mempty = noChannels #if !MIN_VERSION_base(4,11,0) mappend = (<>) diff --git a/src/Matterhorn/Types/KeyEvents.hs b/src/Matterhorn/Types/KeyEvents.hs --- a/src/Matterhorn/Types/KeyEvents.hs +++ b/src/Matterhorn/Types/KeyEvents.hs @@ -72,6 +72,8 @@ | EditorEndEvent | EditorYankEvent + | CycleChannelListSorting + | SelectNextTabEvent | SelectPreviousTabEvent @@ -96,6 +98,8 @@ | ScrollTopEvent | ScrollBottomEvent | SelectOldestMessageEvent + | ChannelListScrollUpEvent + | ChannelListScrollDownEvent -- select events---not the same as scrolling sometimes! | SelectUpEvent @@ -193,6 +197,8 @@ , EditorEndEvent , EditorYankEvent + , CycleChannelListSorting + , EnterFlaggedPostsEvent , ToggleChannelListVisibleEvent , ToggleExpandedChannelTopicsEvent @@ -207,6 +213,8 @@ , ScrollDownEvent , ScrollLeftEvent , ScrollRightEvent + , ChannelListScrollUpEvent + , ChannelListScrollDownEvent , PageUpEvent , PageDownEvent , PageLeftEvent @@ -435,6 +443,8 @@ EditorEndEvent -> "editor-end" EditorYankEvent -> "editor-yank" + CycleChannelListSorting -> "cycle-channel-list-sorting" + NextTeamEvent -> "next-team" PrevTeamEvent -> "prev-team" MoveCurrentTeamLeftEvent -> "move-current-team-left" @@ -454,6 +464,10 @@ ScrollDownEvent -> "scroll-down" ScrollLeftEvent -> "scroll-left" ScrollRightEvent -> "scroll-right" + + ChannelListScrollUpEvent -> "channel-list-scroll-up" + ChannelListScrollDownEvent -> "channel-list-scroll-down" + PageUpEvent -> "page-up" PageDownEvent -> "page-down" PageLeftEvent -> "page-left" diff --git a/src/Matterhorn/Types/RichText.hs b/src/Matterhorn/Types/RichText.hs --- a/src/Matterhorn/Types/RichText.hs +++ b/src/Matterhorn/Types/RichText.hs @@ -267,7 +267,9 @@ parseUsername = P.try $ do void $ C.symbol userSigilChar let chunk = C.satisfyWord (const True) <|> C.symbol '_' <|> C.symbol '-' - [period] = C.tokenize "" "." + period = case C.tokenize "" "." of + [p] -> p + _ -> error "BUG: parseUsername: failed to tokenize basic input" uts <- intersperse period <$> P.sepBy1 chunk (C.symbol '.') return $ singleI $ EUser $ C.untokenize uts diff --git a/src/Matterhorn/Windows/ViewMessage.hs b/src/Matterhorn/Windows/ViewMessage.hs --- a/src/Matterhorn/Windows/ViewMessage.hs +++ b/src/Matterhorn/Windows/ViewMessage.hs @@ -15,7 +15,6 @@ import qualified Data.Set as S import qualified Data.Map as M -import Data.Maybe ( fromJust ) import qualified Data.Text as T import qualified Data.Foldable as F import qualified Graphics.Vty as Vty @@ -44,8 +43,8 @@ messageEntry :: TeamId -> TabbedWindowEntry ViewMessageWindowTab messageEntry tId = TabbedWindowEntry { tweValue = VMTabMessage - , tweRender = renderTab - , tweHandleEvent = handleEvent + , tweRender = renderTab tId + , tweHandleEvent = handleEvent tId , tweTitle = tabTitle , tweShowHandler = onShow tId } @@ -53,8 +52,8 @@ reactionsEntry :: TeamId -> TabbedWindowEntry ViewMessageWindowTab reactionsEntry tId = TabbedWindowEntry { tweValue = VMTabReactions - , tweRender = renderTab - , tweHandleEvent = handleEvent + , tweRender = renderTab tId + , tweHandleEvent = handleEvent tId , tweTitle = tabTitle , tweShowHandler = onShow tId } @@ -79,31 +78,36 @@ vScrollToBeginning vs hScrollToBeginning vs -renderTab :: ViewMessageWindowTab -> ChatState -> Widget Name -renderTab tab cs = - let latestMessage = case cs^.csCurrentTeam.tsViewedMessage of +renderTab :: TeamId -> ViewMessageWindowTab -> ChatState -> Widget Name +renderTab tId tab cs = + let mLatestMessage = case cs^.csTeam(tId).tsViewedMessage of Nothing -> error "BUG: no message to show, please report!" - Just (m, _) -> getLatestMessage cs m - in case tab of - VMTabMessage -> viewMessageBox cs latestMessage - VMTabReactions -> reactionsText cs latestMessage + Just (m, _) -> getLatestMessage cs tId m + in case mLatestMessage of + Nothing -> emptyWidget + Just latestMessage -> + case tab of + VMTabMessage -> viewMessageBox cs tId latestMessage + VMTabReactions -> reactionsText cs tId latestMessage -getLatestMessage :: ChatState -> Message -> Message -getLatestMessage cs m = +getLatestMessage :: ChatState -> TeamId -> Message -> Maybe Message +getLatestMessage cs tId m = case m^.mMessageId of - Nothing -> m - Just mId -> fromJust $ findMessage mId $ cs^.csCurrentChannel.ccContents.cdMessages + Nothing -> Just m + Just mId -> do + cId <- cs^.csCurrentChannelId(tId) + chan <- cs^?csChannel(cId) + findMessage mId $ chan^.ccContents.cdMessages -handleEvent :: ViewMessageWindowTab -> Vty.Event -> MH () -handleEvent VMTabMessage = - void . handleKeyboardEvent viewMessageKeybindings (const $ return ()) -handleEvent VMTabReactions = - void . handleKeyboardEvent viewMessageReactionsKeybindings (const $ return ()) +handleEvent :: TeamId -> ViewMessageWindowTab -> Vty.Event -> MH () +handleEvent tId VMTabMessage = + void . handleKeyboardEvent (viewMessageKeybindings tId) (const $ return ()) +handleEvent tId VMTabReactions = + void . handleKeyboardEvent (viewMessageReactionsKeybindings tId) (const $ return ()) -reactionsText :: ChatState -> Message -> Widget Name -reactionsText st m = viewport (ViewMessageReactionsArea tId) Vertical body +reactionsText :: ChatState -> TeamId -> Message -> Widget Name +reactionsText st tId m = viewport (ViewMessageReactionsArea tId) Vertical body where - tId = st^.csCurrentTeamId body = case null reacList of True -> txt "This message has no reactions." False -> vBox $ mkEntry <$> reacList @@ -116,7 +120,7 @@ in (clickableName <+> (padLeft (Pad 1) count)) <=> (padLeft (Pad 2) usernameList) - hs = getHighlightSet st + hs = getHighlightSet st tId clickableUsernames i (EUser un) = Just $ ClickableUsername (ViewMessageReactionsArea tId) i un @@ -140,17 +144,16 @@ Just n -> clickable n w Nothing -> w -viewMessageBox :: ChatState -> Message -> Widget Name -viewMessageBox st msg = +viewMessageBox :: ChatState -> TeamId -> Message -> Widget Name +viewMessageBox st tId msg = let maybeWarn = if not (msg^.mDeleted) then id else warn warn w = vBox [w, hBorder, deleteWarning] - tId = st^.csCurrentTeamId deleteWarning = withDefAttr errorMessageAttr $ txtWrap $ "Alert: this message has been deleted and " <> "will no longer be accessible once this window " <> "is closed." mkBody vpWidth = - let hs = getHighlightSet st + let hs = getHighlightSet st tId parent = case msg^.mInReplyToMsg of NotAReply -> Nothing InReplyTo pId -> getMessageForPostId st pId @@ -177,80 +180,64 @@ ctx <- getContext render $ maybeWarn $ viewport (ViewMessageArea tId) Both $ mkBody (ctx^.availWidthL) -viewMessageKeybindings :: KeyConfig -> KeyHandlerMap -viewMessageKeybindings = mkKeybindings viewMessageKeyHandlers +viewMessageKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +viewMessageKeybindings tId = mkKeybindings (viewMessageKeyHandlers tId) -viewMessageKeyHandlers :: [KeyEventHandler] -viewMessageKeyHandlers = +viewMessageKeyHandlers :: TeamId -> [KeyEventHandler] +viewMessageKeyHandlers tId = let vs = viewportScroll . ViewMessageArea in [ mkKb PageUpEvent "Page up" $ do - tId <- use csCurrentTeamId mh $ vScrollBy (vs tId) (-1 * pageAmount) , mkKb PageDownEvent "Page down" $ do - tId <- use csCurrentTeamId mh $ vScrollBy (vs tId) pageAmount , mkKb PageLeftEvent "Page left" $ do - tId <- use csCurrentTeamId mh $ hScrollBy (vs tId) (-2 * pageAmount) , mkKb PageRightEvent "Page right" $ do - tId <- use csCurrentTeamId mh $ hScrollBy (vs tId) (2 * pageAmount) , mkKb ScrollUpEvent "Scroll up" $ do - tId <- use csCurrentTeamId mh $ vScrollBy (vs tId) (-1) , mkKb ScrollDownEvent "Scroll down" $ do - tId <- use csCurrentTeamId mh $ vScrollBy (vs tId) 1 , mkKb ScrollLeftEvent "Scroll left" $ do - tId <- use csCurrentTeamId mh $ hScrollBy (vs tId) (-1) , mkKb ScrollRightEvent "Scroll right" $ do - tId <- use csCurrentTeamId mh $ hScrollBy (vs tId) 1 , mkKb ScrollBottomEvent "Scroll to the end of the message" $ do - tId <- use csCurrentTeamId mh $ vScrollToEnd (vs tId) , mkKb ScrollTopEvent "Scroll to the beginning of the message" $ do - tId <- use csCurrentTeamId mh $ vScrollToBeginning (vs tId) ] -viewMessageReactionsKeybindings :: KeyConfig -> KeyHandlerMap -viewMessageReactionsKeybindings = mkKeybindings viewMessageReactionsKeyHandlers +viewMessageReactionsKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap +viewMessageReactionsKeybindings tId = mkKeybindings (viewMessageReactionsKeyHandlers tId) -viewMessageReactionsKeyHandlers :: [KeyEventHandler] -viewMessageReactionsKeyHandlers = +viewMessageReactionsKeyHandlers :: TeamId -> [KeyEventHandler] +viewMessageReactionsKeyHandlers tId = let vs = viewportScroll . ViewMessageReactionsArea in [ mkKb PageUpEvent "Page up" $ do - tId <- use csCurrentTeamId mh $ vScrollBy (vs tId) (-1 * pageAmount) , mkKb PageDownEvent "Page down" $ do - tId <- use csCurrentTeamId mh $ vScrollBy (vs tId) pageAmount , mkKb ScrollUpEvent "Scroll up" $ do - tId <- use csCurrentTeamId mh $ vScrollBy (vs tId) (-1) , mkKb ScrollDownEvent "Scroll down" $ do - tId <- use csCurrentTeamId mh $ vScrollBy (vs tId) 1 , mkKb ScrollBottomEvent "Scroll to the end of the reactions list" $ do - tId <- use csCurrentTeamId mh $ vScrollToEnd (vs tId) , mkKb ScrollTopEvent "Scroll to the beginning of the reactions list" $ do - tId <- use csCurrentTeamId mh $ vScrollToBeginning (vs tId) ] diff --git a/src/Matterhorn/Zipper.hs b/src/Matterhorn/Zipper.hs --- a/src/Matterhorn/Zipper.hs +++ b/src/Matterhorn/Zipper.hs @@ -3,7 +3,7 @@ , fromList , toList , focus - , unsafeFocus + , focusHeading , left , leftL , right @@ -75,8 +75,14 @@ focus :: Zipper a b -> Maybe b focus = C.focus . zRing -unsafeFocus :: Zipper a b -> b -unsafeFocus = fromJust . focus +-- Return the heading value corresponding to the focused value, if any +-- element is in focus +focusHeading :: (Eq b) => Zipper a b -> Maybe a +focusHeading z = do + f <- focus z + let matchesElems (_, es) = f `elem` es + matches = filter matchesElems $ toList z + listToMaybe $ fst <$> matches -- Turn a list into a wraparound zipper, focusing on the head fromList :: (Eq b) => [(a, [b])] -> Zipper a b