diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,85 @@ +50200.13.0 +========== + +New features: + * Matterhorn now has optional mouse support! Thanks to Hari Menon + (@phsmenon) for this work. From the User Guide: Matterhorn supports + mouse interaction with some UI elements. To enable mouse support, set + `enableMouseMode` to `True` in your Matterhorn configuration. Mouse + interaction is supported on the following user interface elements: + * Channel list entries can be clicked to switch channels. + * Channel list entries in channel selection mode (`C-g`) can be + clicked to switch to the selected channel match. + * Team names in the team list can be clicked to switch teams. + * URLs and post links in the URL list (`C-o`) can be clicked to open + them. + * URLs in messages can be clicked to open them using the configured + URL opener. + * Post links in messages can be clicked to switch to the channel + containing the post. + * Usernames in messages can be clicked to switch to the direct + message channel for the clicked user. + * Usernames in the "Reactions" tab of the message view window can be + clicked to switch to the direct message channel for the clicked + user. + * Reactions to messages can be toggled by clicking on them. + Click-toggling also works in the "Search Emoji" window as well as + the "Reactions" tab of the message view window. + * Notification scripts now have a richer versioned interface. Thanks to + Dave Lamkins (@TieDyedDevil) for this work. Details can be found in + `docs/notification-scripts.md`. + * Favorite channel support was added. Thanks to Ajay Eeralla + (@ajayeeralla) for this work. + * Matterhorn now honors the "favorite" status of channels, displaying + favorite channels together in a new channel list category. + * Matterhorn got a new command, `/toggle-favorite`, to toggle the + favorite status of the current channel. + * A new `/attach` command can be used to attach a file to the message + being composed. + * The URL list got a new keybinding to prompt for attachment save path + for the selected entry. This added a new key event, `save-attachment` + (default binding: `s`), for the URL list. When triggered, if the + selected URL entry is for an attachment, a dialog box is shown + prompting the user for a path to which to save the attachment. (If + the entry is not an attachment, the event is ignored.) + * The attachment file browser's key bindings can now be customized as + Matterhorn key events. Thanks to Dave Lamkins (@TieDyedDevil) for + this work. (#628) + * Matterhorn now supports pipe table syntax in Mattermost messages. + * The URL selection mode now displays available actions in its UI. + The URL list's bottom bar now indicates any actions that are + available for the selected link, similarly to how Matterhorn displays + such actions for messages in message selection mode. This change also + adds a new theme attribute, `urlSelectStatus`, that is used to render + the keybindings shown in the options list. + +Bug fixes: + * Message reactions are now wrapped rather than being truncated by the + window width (#715) + * When switching away from one team to another, the previous team now + has its current channel marked as viewed to fix a bug where unread + messages in that channel were still seen as unread. + +Other improvements: + * Channel autocompletion alternatives are now trimmed to one row in + height (thanks Karl Smeltzer (@karljs)). + * User metadata is now updated correctly in reponse to websocket events + (#697; thanks Karl Smeltzer (@karljs)). + * "No route to host" exceptions no longer trigger "unexpected error" + messages (#714) + * Matterhorn no longer exposes the server's `/msg` command (#657) + * Matterhorn no longer exposes the server's `/search` command since + Matterhorn provides its own UI for that command. + * The `/group-msg` command was renamed to `/group-create` to make it + more distinct from the server command which has a different behavior + (#657). + * The `/remove-user` command was renamed to `/remove` and the server's + `/remove` command is no longer exposed (#657). + * Matterhorn now shows the team position and count in team list (#692). + * Matterhorn now falls back to UTC when it is unable to load local time + zone data (#695). + 50200.12.0 ========== diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -86,6 +86,7 @@ * Custom notifications via notification scripts (see the `activityNotifyCommand` configuration setting and `docs/notification-scripts.md` for details). +* Optional mouse support # Our Versioning Scheme diff --git a/docs/commands.md b/docs/commands.md --- a/docs/commands.md +++ b/docs/commands.md @@ -4,13 +4,14 @@ | ------- | ----------- | | `/add-user` | Search for a user to add to the current channel | | `/add-user <@user>` | Add a user to the current channel | +| `/attach ` | Attach a given file without browsing | | `/create-channel ` | Create a new public channel | | `/create-private-channel ` | Create a new private channel | | `/delete-channel` | Delete the current channel | | `/flags` | Open a window of your flagged posts | | `/focus <~channel>` | Focus on a channel or user | | `/focus` | Select from available channels | -| `/group-msg <@user [@user ...]>` | Create a group chat | +| `/group-create <@user [@user ...]>` | Create a group chat | | `/help` | Show the main help screen | | `/help ` | Show help about a particular topic | | `/hide` | Hide the current DM or group channel from the channel list | @@ -34,7 +35,7 @@ | `/pinned-posts` | Open a window of this channel's pinned posts | | `/quit` | Exit Matterhorn | | `/reconnect` | Force a reconnection attempt to the server | -| `/remove-user <@user>` | Remove a user from the current channel | +| `/remove <@user>` | Remove a user from the current channel | | `/rename-channel-url ` | Rename the current channel's URL name | | `/right` | Focus on the next channel | | `/search ` | Search for posts with given terms | @@ -45,6 +46,7 @@ | `/theme ` | Set the color theme | | `/toggle-channel-list` | Toggle channel list visibility | | `/toggle-expanded-topics` | Toggle expanded channel topics | +| `/toggle-favorite` | Toggle the favorite status of the current channel | | `/toggle-message-timestamps` | Toggle message timestamps | | `/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 @@ -115,6 +115,7 @@ | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- | | `Enter` | (non-customizable key) | Open the selected URL, if any | +| `s` | `save-attachment` | Save the selected attachment | | `Esc`, `C-c` | `cancel` | Cancel URL selection | | `k`, `Up` | `select-up` | Move cursor up | | `j`, `Down` | `select-down` | Move cursor down | @@ -186,6 +187,17 @@ | ---------- | ---------- | ----------- | | `Esc`, `C-c` | `cancel` | Cancel attachment file browse | | `o` | `open-attachment` | Open the selected file using the URL open command | +| `/` | `filebrowser-begin-search` | Begin search for name in list | +| `Enter` | `filebrowser-select-file-or-enter-directory` | Select file or enter directory | +| `Space` | `filebrowser-select-current` | Select file | +| `C-b`, `PgUp` | `filebrowser-list-page-up` | Move cursor one page up | +| `C-f`, `PgDown` | `filebrowser-list-page-down` | Move cursor one page down | +| `C-u` | `filebrowser-list-half-page-up` | Move cursor one-half page up | +| `C-d` | `filebrowser-list-half-page-down` | Move cursor one-half page down | +| `g`, `Home` | `filebrowser-list-top` | Move cursor to top of list | +| `G`, `End` | `filebrowser-list-bottom` | Move cursor to bottom of list | +| `j`, `C-n`, `Down` | `filebrowser-list-next` | Move cursor down | +| `k`, `C-p`, `Up` | `filebrowser-list-previous` | Move cursor up | # Flagged Messages | Keybinding | Event Name | Description | diff --git a/docs/notification-scripts.md b/docs/notification-scripts.md --- a/docs/notification-scripts.md +++ b/docs/notification-scripts.md @@ -14,7 +14,10 @@ to finish, which will cause Matterhorn to delay looking at incoming network messages, etc. -* Matterhorn will invoke the command with three arguments: +* The notifier behavior changes according to the activityNotifyVersion + setting in the configuration file. + +* NotifyV1: Matterhorn will invoke the command with three arguments: * The mention argument, whose values are: * "1" - this value indicates that the user running Matterhorn was mentioned in the message body. @@ -25,9 +28,17 @@ * The message body, sanitized of tabs (converted to spaces) and escape characters (converted to ""). +* NotifyV2: Matterhorn will invoke the command with zero arguments, + passing notification details via JSON to the command's standard input. + * NotifyV2 JSON payload fields: + * "version": "2" + * "from": "sender name" + * "message": "message text..." + * "mention": boolean (true or false: did sender mention me?) + * Matterhorn will wait for the process to terminate. If the process emits any output to standard out OR if the command exits with a - non-zero xit status, Matterhorn will consider that evidence that + non-zero exit status, Matterhorn will consider that evidence that the command has failed and will display an error to the user in the current channel. The standard out and standard error output will be logged to a temporary subprocess log file and the log file's path will diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 50200.12.0 +version: 50200.13.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 @@ -53,6 +53,7 @@ Matterhorn.Draw.ChannelList Matterhorn.Draw.ChannelListOverlay Matterhorn.Draw.ChannelTopicWindow + Matterhorn.Draw.SaveAttachmentWindow Matterhorn.Draw.DeleteChannelConfirm Matterhorn.Draw.LeaveChannelConfirm Matterhorn.Draw.ListOverlay @@ -76,6 +77,7 @@ Matterhorn.Events.ChannelListOverlay Matterhorn.Events.ChannelSelect Matterhorn.Events.ChannelTopicWindow + Matterhorn.Events.SaveAttachmentWindow Matterhorn.Events.DeleteChannelConfirm Matterhorn.Events.EditNotifyPrefs Matterhorn.Events.Keybindings @@ -109,6 +111,7 @@ Matterhorn.State.ChannelSelect Matterhorn.State.Channels Matterhorn.State.ChannelTopicWindow + Matterhorn.State.SaveAttachmentWindow Matterhorn.State.Common Matterhorn.State.Editing Matterhorn.State.Flagging @@ -154,7 +157,7 @@ ghc-options: -fhide-source-paths build-depends: base >=4.8 && <5 - , mattermost-api == 50200.10.0 + , mattermost-api == 50200.11.0 , base-compat >= 0.9 && < 0.12 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.7 @@ -168,7 +171,7 @@ , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.5 - , brick >= 0.59 && < 0.60 + , brick >= 0.62 && < 0.63 , brick-skylighting >= 0.2 && < 0.4 , vty >= 5.32 && < 5.33 , word-wrap >= 0.4.0 && < 0.5 diff --git a/src/Matterhorn/App.hs b/src/Matterhorn/App.hs --- a/src/Matterhorn/App.hs +++ b/src/Matterhorn/App.hs @@ -42,6 +42,8 @@ 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 @@ -84,6 +86,7 @@ let output = Vty.outputIface vty Vty.setMode output Vty.BracketedPaste True Vty.setMode output Vty.Hyperlink $ configHyperlinkingMode config + Vty.setMode output Vty.Mouse $ configMouseMode config return vty (st, vty) <- setupState mkVty (optLogLocation opts) config diff --git a/src/Matterhorn/Command.hs b/src/Matterhorn/Command.hs --- a/src/Matterhorn/Command.hs +++ b/src/Matterhorn/Command.hs @@ -21,6 +21,7 @@ import qualified Network.Mattermost.Exceptions as MM import qualified Network.Mattermost.Types as MM +import Matterhorn.State.Attachments import Matterhorn.Connection ( connectWebsockets ) import Matterhorn.Constants ( userSigil, normalChannelSigil ) import Matterhorn.HelpTopics @@ -202,7 +203,7 @@ (UserArg NoArg) $ \ (uname, ()) -> addUserByNameToCurrentChannel uname - , Cmd "remove-user" "Remove a user from the current channel" + , Cmd "remove" "Remove a user from the current channel" (UserArg NoArg) $ \ (uname, ()) -> removeUserFromCurrentChannel uname @@ -246,7 +247,7 @@ , Cmd "sh" "List the available shell scripts" NoArg $ \ () -> listScripts - , Cmd "group-msg" "Create a group chat" + , Cmd "group-create" "Create a group chat" (LineArg (userSigil <> "user [" <> userSigil <> "user ...]")) createGroupChannel @@ -276,6 +277,12 @@ , 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 "toggle-favorite" "Toggle the favorite status of the current channel" NoArg $ \_ -> + toggleChannelFavoriteStatus ] displayUsernameAttribute :: Text -> MH () diff --git a/src/Matterhorn/Config.hs b/src/Matterhorn/Config.hs --- a/src/Matterhorn/Config.hs +++ b/src/Matterhorn/Config.hs @@ -109,6 +109,8 @@ (configEnableAspell defaultConfig) configSyntaxDirs <- fieldDefOf "syntaxDirectories" syntaxDirsField [] configActivityNotifyCommand <- fieldMb "activityNotifyCommand" + configActivityNotifyVersion <- fieldDefOf "activityNotifyVersion" + notifyVersion (configActivityNotifyVersion defaultConfig) configShowMessageTimestamps <- fieldFlagDef "showMessageTimestamps" (configShowMessageTimestamps defaultConfig) configActivityBell <- fieldFlagDef "activityBell" @@ -130,6 +132,8 @@ configDirectChannelExpirationDays <- fieldDefOf "directChannelExpirationDays" number (configDirectChannelExpirationDays defaultConfig) configDefaultAttachmentPath <- fieldMbOf "defaultAttachmentPath" filePathField + configMouseMode <- fieldFlagDef "enableMouseMode" + (configMouseMode defaultConfig) let configAbsPath = Nothing configUserKeys = mempty @@ -192,6 +196,14 @@ _ -> Left ("Invalid value " <> show t <> "; must be one of: Disabled, Active, ActiveCount") +notifyVersion :: Text -> Either String NotificationVersion +notifyVersion t = + case t of + "1" -> Right NotifyV1 + "2" -> Right NotifyV2 + _ -> Left ("Invalid value " <> show t + <> "; must be one of NotifyV1, NotifyV2") + cpuUsagePolicy :: Text -> Either String CPUUsagePolicy cpuUsagePolicy t = case T.toLower t of @@ -241,6 +253,7 @@ , configURLOpenCommand = Nothing , configURLOpenCommandInteractive = False , configActivityNotifyCommand = Nothing + , configActivityNotifyVersion = NotifyV1 , configActivityBell = False , configShowMessageTimestamps = True , configShowBackground = Disabled @@ -262,6 +275,7 @@ , configCpuUsagePolicy = MultipleCPUs , configDefaultAttachmentPath = Nothing , configChannelListOrientation = ChannelListLeft + , configMouseMode = False } findConfig :: Maybe FilePath -> IO (Either String ([String], Config)) diff --git a/src/Matterhorn/Draw.hs b/src/Matterhorn/Draw.hs --- a/src/Matterhorn/Draw.hs +++ b/src/Matterhorn/Draw.hs @@ -10,6 +10,7 @@ import Lens.Micro.Platform ( _2, singular, _Just ) import Matterhorn.Draw.ChannelTopicWindow +import Matterhorn.Draw.SaveAttachmentWindow import Matterhorn.Draw.DeleteChannelConfirm import Matterhorn.Draw.LeaveChannelConfirm import Matterhorn.Draw.Main @@ -46,6 +47,7 @@ ManageAttachmentsBrowseFiles -> drawManageAttachments st : mainLayersMonochrome EditNotifyPrefs -> drawNotifyPrefs st : mainLayersMonochrome ChannelTopicWindow -> drawChannelTopicWindow st : mainLayersMonochrome + SaveAttachmentWindow _ -> drawSaveAttachmentWindow st : mainLayersMonochrome where mainLayers = drawMain True st mainLayersMonochrome = drawMain False st 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 @@ -190,7 +190,7 @@ , padTo displayNameWidth $ withDefAttr channelNameAttr $ txt $ sanitizeUserText $ channelDisplayName c - , txt $ sanitizeUserText $ channelPurpose c + , vLimit 1 $ txt $ sanitizeUserText $ channelPurpose c ] renderCommandCompletion :: CompletionSource -> Text -> Text -> Text -> Widget Name 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 @@ -77,7 +77,9 @@ viewport (ChannelList tId) Vertical body where myUsername_ = myUsername st - renderEntry s e = renderChannelListEntry myUsername_ $ mkChannelEntryData s 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 ChannelSelect -> @@ -101,6 +103,7 @@ let (unread, label) = case g of ChannelGroupPublicChannels u -> (u, "Public Channels") ChannelGroupPrivateChannels u -> (u, "Private Channels") + ChannelGroupFavoriteChannels u -> (u, "Favorite Channels") ChannelGroupDirectMessages u -> (u, "Direct Messages") addUnread = if unread > 0 then (<+> (withDefAttr unreadGroupMarkerAttr $ txt "*")) @@ -135,18 +138,18 @@ } where cId = channelListEntryChannelId e + unread = channelListEntryUnread e Just chan = findChannelById cId (st^.csChannels) - unread = hasUnread' chan recent = isRecentChannel st cId ret = isReturnChannel st cId current = isCurrentChannel st cId muted = isMuted chan - (name, normalSigil, addSpace, status) = case e of - CLChannel _ -> + (name, normalSigil, addSpace, status) = case channelListEntryType e of + CLChannel -> (chan^.ccInfo.cdDisplayName, Nothing, False, Nothing) - CLGroupDM _ -> + CLGroupDM -> (chan^.ccInfo.cdDisplayName, Just " ", True, Nothing) - CLUserDM _ uId -> + CLUserDM uId -> let Just u = userById uId st uname = if useNickname st then u^.uiNickName.non (u^.uiName) @@ -202,7 +205,8 @@ | entryHasUnread entryData -> withDefAttr unreadChannelAttr | otherwise -> id - in decorate $ maybeSelect $ + in clickable (ChannelSelectEntry match) $ + decorate $ maybeSelect $ decorateEntry entryData $ decorateMentions entryData $ padRight Max $ hBox [ txt $ entrySigil entryData <> preMatch 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 @@ -33,7 +33,7 @@ , hBorderWithLabel (withDefAttr clientEmphAttr $ txt "Preview") , vLimit previewHeight $ viewport (ChannelTopicEditorPreview tId) Vertical $ - renderText' (Just baseUrl) "" hSet topicTxtWithCursor + renderText' (Just baseUrl) "" hSet Nothing topicTxtWithCursor , hBorder , hBox [ padRight Max $ padLeft (Pad 1) $ 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 @@ -8,7 +8,7 @@ import Brick.Widgets.Border import Brick.Widgets.Border.Style import Brick.Widgets.Center ( hCenter ) -import Brick.Widgets.List ( listElements ) +import Brick.Widgets.List ( listElements, listSelectedElement ) import Brick.Widgets.Edit ( editContentsL, renderEditor, getEditContents ) import Control.Arrow ( (>>>) ) import Data.Char ( isSpace, isPunctuation ) @@ -39,13 +39,14 @@ import Matterhorn.Draw.RichText import Matterhorn.Events.Keybindings import Matterhorn.Events.MessageSelect +import Matterhorn.Events.UrlSelect import Matterhorn.State.MessageSelect import Matterhorn.Themes import Matterhorn.TimeUtils ( justAfter, justBefore ) import Matterhorn.Types import Matterhorn.Types.Common ( sanitizeUserText ) import Matterhorn.Types.DirectionalSeq ( emptyDirSeq ) -import Matterhorn.Types.RichText ( parseMarkdown, TeamBaseURL ) +import Matterhorn.Types.RichText ( parseMarkdown, TeamBaseURL, Inline(EHyperlink, EUser) ) import Matterhorn.Types.KeyEvents import qualified Matterhorn.Zipper as Z @@ -334,9 +335,12 @@ 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 + hs (Just clickableInlines) (channelNameString <> maybeTopic) renderCurrentChannelDisplay :: ChatState -> HighlightSet -> Widget Name @@ -396,11 +400,14 @@ 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 @@ -517,24 +524,27 @@ teamList st = let curTid = st^.csCurrentTeamId z = st^.csTeamZipper + Just pos = Z.position z teams = (\tId -> st^.csTeam(tId)) <$> (concat $ snd <$> Z.toList z) + numTeams = length teams entries = mkEntry <$> teams mkEntry ts = let tId = teamId $ _tsTeam ts unread = uCount > 0 uCount = unreadCount tId + tName = ClickableTeamListEntry tId in (if tId == curTid then visible . withDefAttr currentTeamAttr else if unread then withDefAttr unreadChannelAttr else id) $ - txt $ + clickable tName $ txt $ (T.strip $ sanitizeUserText $ teamDisplayName $ _tsTeam ts) unreadCount tId = sum $ fmap (nonDMChannelListGroupUnread . fst) $ Z.toList $ st^.csTeam(tId).tsFocus - in if length teams == 1 + in if numTeams == 1 then emptyWidget - else vBox [ hBox [ padRight (Pad 1) $ txt "Teams:" + else vBox [ hBox [ padRight (Pad 1) $ txt $ T.pack $ "Teams (" <> show (pos + 1) <> "/" <> show numTeams <> "):" , vLimit 1 $ viewport TeamList Horizontal $ hBox $ intersperse (txt " ") entries @@ -556,6 +566,36 @@ withDefAttr errorMessageAttr $ border $ str msg +urlSelectBottomBar :: ChatState -> Widget Name +urlSelectBottomBar st = + case listSelectedElement $ st^.csCurrentTeam.tsUrlList of + Nothing -> hBorder + Just (_, (_, link)) -> + let options = [ ( isFile + , ev SaveAttachmentEvent + , "save attachment" + ) + ] + ev = keyEventBindings st urlSelectKeybindings + isFile entry = case entry^.linkTarget of + LinkFileId {} -> True + _ -> False + optionList = if null usableOptions + then txt "(no actions available for this link)" + else hBox $ intersperse (txt " ") usableOptions + usableOptions = catMaybes $ mkOption <$> options + mkOption (f, k, desc) = if f link + then Just $ withDefAttr urlSelectStatusAttr (txt k) <+> + txt (":" <> desc) + else Nothing + in hBox [ borderElem bsHorizontal + , txt "[" + , txt "Options: " + , optionList + , txt "]" + , hBorder + ] + messageSelectBottomBar :: ChatState -> Widget Name messageSelectBottomBar st = case getSelectedMessage st of @@ -574,17 +614,8 @@ hasURLs = numURLs > 0 openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s hasVerb = isJust (findVerbatimChunk (postMsg^.mText)) + ev = keyEventBindings st messageSelectKeybindings -- make sure these keybinding pieces are up-to-date! - ev e = - let keyconf = st^.csResources.crConfiguration.configUserKeysL - KeyHandlerMap keymap = messageSelectKeybindings keyconf - in T.intercalate "," - [ ppBinding (eventToBinding k) - | KH { khKey = k - , khHandler = h - } <- M.elems keymap - , kehEventTrigger h == ByEvent e - ] options = [ ( not . isGap , ev YankWholeMessageEvent , "yank-all" @@ -647,6 +678,30 @@ , hBorder ] +-- | Resolve the specified key event into a pretty-printed +-- representation of the active bindings for that event, using the +-- specified key handler map builder. If the event has more than one +-- active binding, the bindings are comma-delimited in the resulting +-- string. +keyEventBindings :: ChatState + -- ^ The current application state + -> (KeyConfig -> KeyHandlerMap) + -- ^ The function to obtain the relevant key handler + -- map + -> KeyEvent + -- ^ The key event to look up + -> T.Text +keyEventBindings st mkBindingsMap e = + let keyconf = st^.csResources.crConfiguration.configUserKeysL + KeyHandlerMap keymap = mkBindingsMap keyconf + in T.intercalate "," + [ ppBinding (eventToBinding k) + | KH { khKey = k + , khHandler = h + } <- M.elems keymap + , kehEventTrigger h == ByEvent e + ] + maybePreviewViewport :: TeamId -> Widget Name -> Widget Name maybePreviewViewport tId w = Widget Greedy Fixed $ do @@ -707,14 +762,16 @@ userInputArea :: ChatState -> HighlightSet -> Widget Name userInputArea st hs = - case st^.csCurrentTeam.tsMode of + 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 - UrlSelect -> hCenter $ hBox [ txt "Press " - , withDefAttr clientEmphAttr $ txt "Enter" - , txt " to open the selected URL or " - , withDefAttr clientEmphAttr $ txt "Escape" - , txt " to cancel." - ] + UrlSelect -> urlSelectInputArea + SaveAttachmentWindow {} -> urlSelectInputArea MessageSelectDeleteConfirm -> renderDeleteConfirm _ -> renderUserCommandBox st hs @@ -748,10 +805,13 @@ ] channelContents = case st^.csCurrentTeam.tsMode of UrlSelect -> renderUrlList st + SaveAttachmentWindow {} -> renderUrlList st _ -> maybeSubdue $ renderCurrentChannelDisplay st hs bottomBorder = case st^.csCurrentTeam.tsMode of MessageSelect -> messageSelectBottomBar st + UrlSelect -> urlSelectBottomBar st + SaveAttachmentWindow {} -> urlSelectBottomBar st _ -> maybeSubdue $ hBox [ showAttachmentCount , hBorder @@ -773,7 +833,7 @@ ] showTypingUsers = - let format = renderText' Nothing (myUsername st) hs + let format = renderText' Nothing (myUsername st) hs Nothing in case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of [] -> emptyWidget [uId] | Just un <- usernameForUserId uId st -> 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 @@ -28,7 +28,7 @@ import qualified Graphics.Vty as V import Lens.Micro.Platform ( (.~), to ) import Network.Mattermost.Lenses ( postEditAtL, postCreateAtL ) -import Network.Mattermost.Types ( ServerTime(..), userUsername ) +import Network.Mattermost.Types ( ServerTime(..), userUsername, postId ) import Prelude () import Matterhorn.Prelude @@ -125,8 +125,12 @@ -- because (depending on the situation) we might use either of the -- message list types for the 'before' and 'after' (i.e. the -- chronological or retrograde message sequences). -unsafeRenderMessageSelection :: (Foldable f, Foldable g) - => ((Message, ThreadState), (f (Message, ThreadState), g (Message, ThreadState))) +unsafeRenderMessageSelection :: (SeqDirection dir1, SeqDirection dir2) + => ( (Message, ThreadState) + , ( DirectionalSeq dir1 (Message, ThreadState) + , DirectionalSeq dir2 (Message, ThreadState) + ) + ) -> (Message -> ThreadState -> Widget Name) -> Widget Name unsafeRenderMessageSelection ((curMsg, curThreadState), (before, after)) doMsgRender = @@ -140,25 +144,55 @@ upperHeight = targetHeight `div` 2 lowerHeight = targetHeight - upperHeight - lowerRender img (m, tState) = render1HLimit doMsgRender V.vertJoin targetHeight img tState m - upperRender img (m, tState) = render1HLimit doMsgRender (flip V.vertJoin) targetHeight img tState m + lowerHalfResults <- renderMessageSeq targetHeight (render1 doMsgRender) vLimit after + upperHalfResults <- renderMessageSeq targetHeight (render1 doMsgRender) cropTopTo before - lowerHalf <- foldM lowerRender V.emptyImage after - upperHalf <- foldM upperRender V.emptyImage before + let upperHalfResultsHeight = sum $ (V.imageHeight . image) <$> upperHalfResults + lowerHalfResultsHeight = sum $ (V.imageHeight . image) <$> lowerHalfResults + curHeight = V.imageHeight $ curMsgResult^.imageL + uncropped = vBox $ fmap resultToWidget $ + (reverse upperHalfResults) <> (curMsgResult : lowerHalfResults) - let curHeight = V.imageHeight $ curMsgResult^.imageL - uncropped = upperHalf V.<-> curMsgResult^.imageL V.<-> lowerHalf - img = if | V.imageHeight lowerHalf < (lowerHeight - curHeight) -> - V.cropTop targetHeight uncropped - | V.imageHeight upperHalf < upperHeight -> - V.cropBottom targetHeight uncropped - | otherwise -> - V.cropTop upperHeight upperHalf V.<-> curMsgResult^.imageL V.<-> - (if curHeight < lowerHeight - then V.cropBottom (lowerHeight - curHeight) lowerHalf - else V.cropBottom lowerHeight lowerHalf) - return $ emptyResult & imageL .~ img + cropTop h w = Widget Fixed Fixed $ do + result <- withReaderT relaxHeight $ render w + render $ cropTopTo h $ resultToWidget result + cropBottom h w = Widget Fixed Fixed $ do + result <- withReaderT relaxHeight $ render w + render $ cropBottomTo h $ resultToWidget result + lowerHalf = vBox $ fmap resultToWidget lowerHalfResults + upperHalf = vBox $ fmap resultToWidget $ reverse upperHalfResults + + render $ if | lowerHalfResultsHeight < (lowerHeight - curHeight) -> + cropTop targetHeight uncropped + | upperHalfResultsHeight < upperHeight -> + vLimit targetHeight uncropped + | otherwise -> + cropTop upperHeight upperHalf <=> (resultToWidget curMsgResult) <=> + (if curHeight < lowerHeight + then cropBottom (lowerHeight - curHeight) lowerHalf + else cropBottom lowerHeight lowerHalf) + +resultToWidget :: Result n -> Widget n +resultToWidget = Widget Fixed Fixed . return + +renderMessageSeq :: (SeqDirection dir) + => Int + -> (Message -> ThreadState -> Widget Name) + -> (Int -> Widget Name -> Widget Name) + -> DirectionalSeq dir (Message, ThreadState) + -> RenderM Name [Result Name] +renderMessageSeq remainingHeight renderFunc limitFunc ms + | messagesLength ms == 0 = return [] + | otherwise = do + let Just (m, threadState) = messagesHead ms + maybeCache = case m^.mMessageId of + Nothing -> id + Just i -> cached (RenderedMessage i) + result <- render $ limitFunc remainingHeight $ maybeCache $ renderFunc m threadState + rest <- renderMessageSeq (remainingHeight - (V.imageHeight $ result^.imageL)) renderFunc limitFunc (messagesDrop 1 ms) + return $ result : rest + renderLastMessages :: ChatState -> HighlightSet -> Maybe ServerTime @@ -175,54 +209,55 @@ isBelow m transition = m^.mDate > transition^.mDate - go :: V.Image -> DirectionalSeq Retrograde (Message, ThreadState) -> RenderM Name V.Image - go img ms | messagesLength ms == 0 = return img - go img ms = do + 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 newMessagesAbove = maybe False (isBelow m) newMessageTransition - newImg <- render1HLimit doMsgRender (flip V.vertJoin) targetHeight img threadState m + + result <- render $ render1 doMsgRender m threadState + + croppedResult <- render $ cropTopTo remainingHeight $ resultToWidget result + -- If the new message fills the window, check whether -- there is still a "New Messages" transition that is -- not displayed. If there is, then we need to replace -- the top line of the new image with a "New Messages" -- indicator. - if V.imageHeight newImg >= targetHeight && newMessagesAbove + if V.imageHeight (result^.imageL) >= remainingHeight then do - transitionResult <- render $ withDefAttr newMessageTransitionAttr $ - hBorderWithLabel (txt "New Messages ↑") - let newImg2 = V.vertJoin (transitionResult^.imageL) - (V.cropTop (targetHeight - 1) newImg) - return newImg2 - else go newImg $ messagesDrop 1 ms + single <- if newMessagesAbove + then do + result' <- render $ + vBox [ withDefAttr newMessageTransitionAttr $ hBorderWithLabel (txt "New Messages ↑") + , cropTopBy 1 $ resultToWidget croppedResult + ] + return result' + else do + return croppedResult + return [single] + else do + let unusedHeight = remainingHeight - V.imageHeight (result^.imageL) + rest <- go unusedHeight $ messagesDrop 1 ms + return $ result : rest - img <- go V.emptyImage msgs - return $ emptyResult & imageL .~ (V.cropTop targetHeight img) + results <- go targetHeight msgs + render $ vBox $ (Widget Fixed Fixed . return) <$> reverse results relaxHeight :: Context -> Context relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL)) -render1HLimit :: (Message -> ThreadState -> Widget Name) - -> (V.Image -> V.Image -> V.Image) - -> Int - -> V.Image - -> ThreadState - -> Message - -> RenderM Name V.Image -render1HLimit doMsgRender fjoin lim img threadState msg - | V.imageHeight img >= lim = return img - | otherwise = fjoin img <$> render1 doMsgRender threadState msg - render1 :: (Message -> ThreadState -> Widget Name) - -> ThreadState -> Message - -> RenderM Name V.Image -render1 doMsgRender threadState msg = case msg^.mDeleted of - True -> return V.emptyImage - False -> do - r <- withReaderT relaxHeight $ - render $ padRight Max $ - doMsgRender msg threadState - return $ r^.imageL + -> ThreadState + -> Widget Name +render1 doMsgRender msg threadState = case msg^.mDeleted of + True -> emptyWidget + False -> + Widget Greedy Fixed $ do + withReaderT relaxHeight $ + render $ padRight Max $ + doMsgRender msg threadState -- | A bundled structure that includes all the information necessary -- to render a given message @@ -281,18 +316,24 @@ Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u Nothing -> Nothing botElem = if isBotMessage msg then txt "[BOT]" else emptyWidget + mId = msg^.mMessageId + clickableAuthor un = case mId of + Nothing -> id + -- We use the index (-1) since indexes for clickable + -- usernames elsewhere in this message start at 0. + Just i -> clickable (ClickableUsernameInMessage i (-1) un) nameElems = case msgUsr of Just un | isEmote msg -> [ withDefAttr pinnedMessageIndicatorAttr $ txt $ if msg^.mPinned then "[PIN]" else "" , txt $ (if msg^.mFlagged then "[!] " else "") <> "*" - , colorUsername mdMyUsername un un + , clickableAuthor un $ colorUsername mdMyUsername un un , botElem , txt " " ] | otherwise -> [ withDefAttr pinnedMessageIndicatorAttr $ txt $ if msg^.mPinned then "[PIN] " else "" - , colorUsername mdMyUsername un un + , clickableAuthor un $ colorUsername mdMyUsername un un , botElem , txt $ (if msg^.mFlagged then "[!]" else "") <> ": " ] @@ -331,13 +372,36 @@ ] msgReac = if Map.null (msg^.mReactions) || (not mdShowReactions) then Nothing - else let renderR e us = + else let renderR e us lst = let n = Set.size us - in if | n == 1 -> " [" <> e <> "]" - | n > 1 -> " [" <> e <> " " <> T.pack (show n) <> "]" - | otherwise -> "" - reactionMsg = Map.foldMapWithKey renderR (msg^.mReactions) - in Just $ withDefAttr emojiAttr $ txt (" " <> reactionMsg) + in if | n == 1 -> makeReactionWidget e us (" [" <> e <> "]") : lst + | otherwise -> makeReactionWidget e us (" [" <> e <> " " <> T.pack (show n) <> "]") : lst + nonEmptyReactions = Map.filter (not . Set.null) $ msg^.mReactions + makeReactionWidget e us t = + let w = txt t in + maybe w (flip clickable w) $ makeName e us + hasAnyReactions = not $ null nonEmptyReactions + makeName e us = do + pid <- postId <$> msg^.mOriginalPost + Just $ ClickableReactionInMessage pid e us + reactionWidget = Widget Fixed Fixed $ do + ctx <- getContext + let lineW = ctx^.availWidthL + reacs <- mapM render $ Map.foldrWithKey renderR [] nonEmptyReactions + let reacLines :: [Result n] -> Int -> [Result n] -> [[Result n]] + reacLines l _ [] = if null l then [] else [l] + reacLines l w (r:rs) = + let rW = V.imageWidth $ r^.imageL + in if rW <= w + then reacLines (l <> [r]) (w - rW) rs + else + let rest = reacLines [] lineW rs + in l : [r] : rest + + render $ vBox $ hBox <$> (fmap (fmap resultToWidget)) (reacLines [] lineW reacs) + in if hasAnyReactions + then Just $ withDefAttr emojiAttr $ txt " " <+> reactionWidget + else Nothing withParent p = case mdThreadState of NoThread -> msgWidget @@ -377,7 +441,7 @@ if mdIndentBlocks then vBox [ hBox nameElems , hBox [txt " ", renderRichText mdMyUsername hs ((subtract 2) <$> w) - mdWrapNonhighlightedCodeBlocks (Blocks bs)] + mdWrapNonhighlightedCodeBlocks (Just clickableNames) (Blocks bs)] ] else nameNextToMessage hs w nameElems bs @@ -385,11 +449,21 @@ Widget Fixed Fixed $ do nameResult <- render $ hBox nameElems let newW = subtract (V.imageWidth (nameResult^.imageL)) <$> w - render $ hBox [ raw (nameResult^.imageL) - , renderRichText mdMyUsername hs newW mdWrapNonhighlightedCodeBlocks (Blocks bs) + render $ hBox [ Widget Fixed Fixed $ return nameResult + , renderRichText mdMyUsername hs newW mdWrapNonhighlightedCodeBlocks (Just clickableNames) (Blocks bs) ] breakCheck i = i `elem` [ELineBreak, ESoftBreak] + + clickableNames i (EHyperlink u _) = + case msg^.mMessageId of + Just mId -> Just $ ClickableURLInMessage mId i $ LinkURL u + Nothing -> Nothing + clickableNames i (EUser name) = + case msg^.mMessageId of + Just mId -> Just $ ClickableUsernameInMessage mId i name + Nothing -> Nothing + clickableNames _ _ = Nothing -- Add the edit sentinel to the end of the last block in the sequence. -- If the last block is a paragraph, append it to that paragraph. 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 @@ -32,7 +32,8 @@ let maybeForce = if sel then forceAttr listSelectedFocusedAttr else id - in maybeForce $ + in clickable (ReactionEmojiListOverlayEntry (mine, e)) $ + maybeForce $ padRight Max $ hBox [ if mine then txt " * " else txt " " , withDefAttr emojiAttr $ txt $ ":" <> e <> ":" 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 @@ -18,6 +18,7 @@ ) import qualified Brick as B import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Table as B import qualified Brick.Widgets.Skylighting as BS import Control.Monad.Reader import qualified Data.Foldable as F @@ -34,17 +35,28 @@ import Matterhorn.Draw.RichText.Flatten import Matterhorn.Draw.RichText.Wrap import Matterhorn.Themes -import Matterhorn.Types ( HighlightSet(..), emptyHSet ) +import Matterhorn.Types ( HighlightSet(..), emptyHSet, SemEq(..) ) import Matterhorn.Types.RichText --- Cursor sentinel for tracking the user's cursor position in previews. -cursorSentinel :: Char -cursorSentinel = '‸' - -- Render markdown with username highlighting -renderRichText :: Text -> HighlightSet -> Maybe Int -> Bool -> Blocks -> Widget a -renderRichText curUser hSet w doWrap (Blocks bs) = +renderRichText :: SemEq a + => Text + -- ^ The username of the currently-authenticated user. + -> HighlightSet + -- ^ A highlight set for highlighting channel and + -- usernames. + -> Maybe Int + -- ^ An optional maximum width. + -> Bool + -- ^ Whether to do line wrapping. + -> Maybe (Int -> Inline -> Maybe a) + -- ^ An optional function to build resource names for + -- clickable regions. + -> Blocks + -- ^ The content to render. + -> Widget a +renderRichText curUser hSet w doWrap nameGen (Blocks bs) = runReader (do blocks <- mapM renderBlock (addBlankLines bs) return $ B.vBox $ toList blocks) @@ -52,8 +64,31 @@ , drawHighlightSet = hSet , drawLineWidth = w , drawDoLineWrapping = doWrap + , drawNameGen = nameGen }) +-- Render text to markdown without username highlighting, permalink +-- detection, or clickable links +renderText :: SemEq a => Text -> Widget a +renderText txt = renderText' Nothing "" emptyHSet Nothing txt + +renderText' :: SemEq a + => Maybe TeamBaseURL + -- ^ An optional base URL against which to match post links. + -> Text + -- ^ The username of the currently-authenticated user. + -> HighlightSet + -- ^ A highlight set for highlighting channel and usernames. + -> Maybe (Int -> Inline -> Maybe a) + -- ^ An optional function to build resource names for + -- clickable regions. + -> Text + -- ^ The text to parse and then render as rich text. + -> Widget a +renderText' baseUrl curUser hSet nameGen t = + renderRichText curUser hSet Nothing True nameGen $ + parseMarkdown baseUrl t + -- Add blank lines only between adjacent elements of the same type, to -- save space addBlankLines :: Seq Block -> Seq Block @@ -66,16 +101,6 @@ go x EmptyL = S.singleton x blank = Para (Inlines $ S.singleton ESpace) --- Render text to markdown without username highlighting or permalink --- detection -renderText :: Text -> Widget a -renderText txt = renderText' Nothing "" emptyHSet txt - -renderText' :: Maybe TeamBaseURL -> Text -> HighlightSet -> Text -> Widget a -renderText' baseUrl curUser hSet t = - renderRichText curUser hSet Nothing True $ - parseMarkdown baseUrl t - vBox :: F.Foldable f => f (Widget a) -> Widget a vBox = B.vBox . toList @@ -89,16 +114,28 @@ maybeHLimit Nothing w = w maybeHLimit (Just i) w = hLimit i w -type M a = Reader DrawCfg a +type M a b = Reader (DrawCfg b) a -data DrawCfg = +data DrawCfg a = DrawCfg { drawCurUser :: Text , drawHighlightSet :: HighlightSet , drawLineWidth :: Maybe Int , drawDoLineWrapping :: Bool + , drawNameGen :: Maybe (Int -> Inline -> Maybe a) } -renderBlock :: Block -> M (Widget a) +renderBlock :: SemEq a => Block -> M (Widget a) a +renderBlock (Table aligns headings body) = do + headingWs <- mapM renderInlines headings + bodyWs <- forM body $ mapM renderInlines + let t = B.table (headingWs : bodyWs) + alignPairs = zip [0..] aligns + align (_, LeftAlignedCol) = id + align (_, DefaultAlignedCol) = id + align (i, RightAlignedCol) = B.alignRight i + align (i, CenterAlignedCol) = B.alignCenter i + applyAlignment = foldr (.) id (align <$> alignPairs) + return $ B.renderTable $ applyAlignment t renderBlock (Para is) = renderInlines is renderBlock (Header n is) = do @@ -149,7 +186,7 @@ , B.Widget B.Fixed B.Fixed $ return childResult ] -renderCodeBlock :: Sky.SyntaxMap -> Sky.Syntax -> Text -> M (Widget a) +renderCodeBlock :: Sky.SyntaxMap -> Sky.Syntax -> Text -> M (Widget a) b renderCodeBlock syntaxMap syntax tx = do let result = Sky.tokenize cfg syntax tx cfg = Sky.TokenizerConfig syntaxMap False @@ -160,7 +197,7 @@ return $ (B.txt $ "[" <> Sky.sName syntax <> "]") B.<=> (padding <+> BS.renderRawSource textWithCursor tokLines) -renderRawCodeBlock :: Text -> M (Widget a) +renderRawCodeBlock :: Text -> M (Widget a) b renderRawCodeBlock tx = do doWrap <- asks drawDoLineWrapping @@ -181,21 +218,22 @@ render $ padding <+> (Widget Fixed Fixed $ return renderedText) -renderInlines :: Inlines -> M (Widget a) +renderInlines :: SemEq a => Inlines -> M (Widget a) a renderInlines es = do w <- asks drawLineWidth hSet <- asks drawHighlightSet curUser <- asks drawCurUser + nameGen <- asks drawNameGen return $ B.Widget B.Fixed B.Fixed $ do ctx <- B.getContext let width = fromMaybe (ctx^.B.availWidthL) w ws = fmap (renderWrappedLine curUser) $ mconcat $ - (doLineWrapping width <$> (F.toList $ flattenInlineSeq hSet es)) + (doLineWrapping width <$> (F.toList $ flattenInlineSeq hSet nameGen es)) B.render (vBox ws) -renderList :: ListType -> ListSpacing -> Seq Blocks -> M (Widget a) +renderList :: SemEq a => ListType -> ListSpacing -> Seq Blocks -> M (Widget a) a renderList ty _spacing bs = do let is = case ty of BulletList _ -> repeat ("• ") @@ -212,17 +250,18 @@ return $ vBox results -renderWrappedLine :: Text -> WrappedLine -> Widget a +renderWrappedLine :: Show a => Text -> WrappedLine a -> Widget a renderWrappedLine curUser l = hBox $ F.toList $ renderFlattenedValue curUser <$> l -renderFlattenedValue :: Text -> FlattenedValue -> Widget a +renderFlattenedValue :: 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) -renderFlattenedValue curUser (SingleInline fi) = addHyperlink $ addStyles widget +renderFlattenedValue curUser (SingleInline fi) = addClickable $ addHyperlink $ addStyles widget where val = fiValue fi mUrl = fiURL fi + mName = fiName fi styles = fiStyles fi addStyles w = foldr addStyle w styles @@ -238,6 +277,10 @@ Nothing -> id Just u -> B.withDefAttr urlAttr . B.hyperlink (unURL u) + addClickable w = case mName of + Nothing -> id w + Just nm -> B.clickable nm w + widget = case val of FSpace -> B.txt " " FUser u -> colorUsername curUser u $ userSigil <> u @@ -265,3 +308,7 @@ removeCursor :: Text -> Text removeCursor = T.filter (/= cursorSentinel) + +-- Cursor sentinel for tracking the user's cursor position in previews. +cursorSentinel :: Char +cursorSentinel = '‸' diff --git a/src/Matterhorn/Draw/RichText/Flatten.hs b/src/Matterhorn/Draw/RichText/Flatten.hs --- a/src/Matterhorn/Draw/RichText/Flatten.hs +++ b/src/Matterhorn/Draw/RichText/Flatten.hs @@ -57,7 +57,7 @@ import qualified Data.Text as T import Matterhorn.Constants ( normalChannelSigil, userSigil ) -import Matterhorn.Types ( HighlightSet(..) ) +import Matterhorn.Types ( HighlightSet(..), SemEq(..) ) import Matterhorn.Types.RichText @@ -80,7 +80,7 @@ deriving (Eq, Show) -- | A flattened inline value. -data FlattenedInline = +data FlattenedInline a = FlattenedInline { fiValue :: FlattenedContent -- ^ The content of the value. , fiStyles :: [InlineStyle] @@ -89,14 +89,17 @@ , fiURL :: Maybe URL -- ^ If present, the URL to which we should -- hyperlink this value. + , fiName :: Maybe a + -- ^ The resource name, if any, that should be used + -- to make this inline clickable once rendered. } deriving (Show) -- | A flattened value. -data FlattenedValue = - SingleInline FlattenedInline +data FlattenedValue a = + SingleInline (FlattenedInline a) -- ^ A single flattened value - | NonBreaking (Seq (Seq FlattenedValue)) + | NonBreaking (Seq (Seq (FlattenedValue a))) -- ^ A sequence of flattened values that MUST be kept together and -- never broken up by line-wrapping deriving (Show) @@ -110,20 +113,23 @@ | Permalink deriving (Eq, Show) -type FlattenM a = ReaderT FlattenEnv (State FlattenState) a +type FlattenM n a = ReaderT (FlattenEnv n) (State (FlattenState n)) a -- | The flatten monad state -data FlattenState = - FlattenState { fsCompletedLines :: Seq (Seq FlattenedValue) +data FlattenState a = + FlattenState { fsCompletedLines :: Seq (Seq (FlattenedValue a)) -- ^ The lines that we have accumulated so far in the -- flattening process - , fsCurLine :: Seq FlattenedValue + , fsCurLine :: Seq (FlattenedValue a) -- ^ The current line we are accumulating in the -- flattening process + , fsNameIndex :: Int + -- ^ The index used to generate a new unique name (of + -- type 'a') to make a region of text clickable. } -- | The flatten monad environment -data FlattenEnv = +data FlattenEnv a = FlattenEnv { flattenStyles :: [InlineStyle] -- ^ The styles that should apply to the current value -- being flattened @@ -133,6 +139,16 @@ , flattenHighlightSet :: HighlightSet -- ^ The highlight set to use to check for valid user or -- channel references + , flattenNameGen :: Maybe (Int -> Inline -> Maybe a) + -- ^ The function to use to generate resource names + -- for clickable inlines. If provided, this is used to + -- determine whether a given Inline should be augmented + -- with a resource name. + , flattenNameFunc :: Maybe (Int -> Maybe a) + -- ^ The currently active function to generate a resource + -- name for any inline. In practice this is just the + -- value of flattenNameGen, but partially applied with a + -- specific Inline prior to flattening that Inline. } -- | Given a sequence of inlines, flatten it into a list of lines of @@ -145,46 +161,117 @@ -- Otherwise it is rewritten as an 'FText' node so that the username -- does not get highlighted. Channel references ('EChannel') are handled -- similarly. -flattenInlineSeq :: HighlightSet -> Inlines -> Seq (Seq FlattenedValue) -flattenInlineSeq hs is = - flattenInlineSeq' initialEnv is +-- +-- The optional name generator function argument is used to assign +-- resource names to each inline that should be clickable once rendered. +-- The result of the name generator function will be stored in the +-- 'fiName' field of each 'FlattenedInline' that results from calling +-- that function on an 'Inline'. +flattenInlineSeq :: SemEq a + => HighlightSet + -> Maybe (Int -> Inline -> Maybe a) + -- ^ A name generator function for clickable inlines. + -- The integer argument is a unique (to this inline + -- sequence) sequence number. + -> Inlines + -> Seq (Seq (FlattenedValue a)) +flattenInlineSeq hs nameGen is = + snd $ flattenInlineSeq' initialEnv 0 is where initialEnv = FlattenEnv { flattenStyles = [] , flattenURL = Nothing , flattenHighlightSet = hs + , flattenNameGen = nameGen + , flattenNameFunc = Nothing } -flattenInlineSeq' :: FlattenEnv -> Inlines -> Seq (Seq FlattenedValue) -flattenInlineSeq' env is = - fsCompletedLines $ execState stBody initialState +flattenInlineSeq' :: SemEq a + => FlattenEnv a + -> Int + -> Inlines + -> (Int, Seq (Seq (FlattenedValue a))) +flattenInlineSeq' env c is = + (fsNameIndex finalState, fsCompletedLines finalState) where - initialState = FlattenState mempty mempty + finalState = execState stBody initialState + initialState = FlattenState { fsCompletedLines = mempty + , fsCurLine = mempty + , fsNameIndex = c + } stBody = runReaderT body env body = do - mapM_ flatten $ unInlines is + flattenInlines is pushFLine -withInlineStyle :: InlineStyle -> FlattenM () -> FlattenM () +flattenInlines :: SemEq a => Inlines -> FlattenM a () +flattenInlines is = do + pairs <- nameInlinePairs + mapM_ wrapFlatten pairs + where + wrapFlatten (nameFunc, i) = withNameFunc nameFunc $ flatten i + + -- For each inline, prior to flattening it, obtain the resource + -- name (if any) that should be assigned to each flattened + -- fragment of the inline. + nameInlinePairs = forM (unInlines is) $ \i -> do + nameFunc <- nameGenWrapper i + return (nameFunc, i) + + -- Determine whether the name generation function will produce + -- a name for this inline. If it does (using a fake sequence + -- number) then return a new name generation function to use for + -- all flattened fragments of this inline. + nameGenWrapper :: Inline -> FlattenM a (Maybe (Int -> Maybe a)) + nameGenWrapper i = do + c <- gets fsNameIndex + nameGen <- asks flattenNameGen + return $ case nameGen of + Nothing -> Nothing + Just f -> if isJust (f c i) then Just (flip f i) else Nothing + +withNameFunc :: Maybe (Int -> Maybe a) -> FlattenM a () -> FlattenM a () +withNameFunc f@(Just _) = withReaderT (\e -> e { flattenNameFunc = f }) +withNameFunc Nothing = id + +withInlineStyle :: InlineStyle -> FlattenM a () -> FlattenM a () withInlineStyle s = withReaderT (\e -> e { flattenStyles = nub (s : flattenStyles e) }) -withHyperlink :: URL -> FlattenM () -> FlattenM () +withHyperlink :: URL -> FlattenM a () -> FlattenM a () withHyperlink u = withReaderT (\e -> e { flattenURL = Just u }) -- | Push a FlattenedContent value onto the current line. -pushFC :: FlattenedContent -> FlattenM () +pushFC :: SemEq a => FlattenedContent -> FlattenM a () pushFC v = do env <- ask + name <- getNextName let styles = flattenStyles env mUrl = flattenURL env fi = FlattenedInline { fiValue = v , fiStyles = styles , fiURL = mUrl + , fiName = name } pushFV $ SingleInline fi +getNextName :: FlattenM a (Maybe a) +getNextName = do + nameGen <- asks flattenNameFunc + case nameGen of + Nothing -> return Nothing + Just f -> f <$> getNextNameIndex + +getNextNameIndex :: FlattenM a Int +getNextNameIndex = do + c <- gets fsNameIndex + modify ( \s -> s { fsNameIndex = c + 1} ) + return c + +setNextNameIndex :: Int -> FlattenM a () +setNextNameIndex i = modify ( \s -> s { fsNameIndex = i } ) + -- | Push a FlattenedValue onto the current line. -pushFV :: FlattenedValue -> FlattenM () +pushFV :: SemEq a => FlattenedValue a -> FlattenM a () pushFV fv = lift $ modify $ \s -> s { fsCurLine = appendFV fv (fsCurLine s) } -- | Append the value to the sequence. @@ -195,41 +282,42 @@ -- non-whitespace text together as one logical token (e.g. "(foo" rather -- than "(" followed by "foo") to avoid undesirable line break points in -- the wrapping process. -appendFV :: FlattenedValue -> Seq FlattenedValue -> Seq FlattenedValue +appendFV :: SemEq a => FlattenedValue a -> Seq (FlattenedValue a) -> Seq (FlattenedValue a) appendFV v line = case (Seq.viewr line, v) of (h :> SingleInline a, SingleInline b) -> case (fiValue a, fiValue b) of (FText aT, FText bT) -> - if fiStyles a == fiStyles b && fiURL a == fiURL b + if fiStyles a == fiStyles b && fiURL a == fiURL b && fiName a `semeq` fiName b then h |> SingleInline (FlattenedInline (FText $ aT <> bT) (fiStyles a) - (fiURL a)) + (fiURL a) + (max (fiName a) (fiName b))) else line |> v _ -> line |> v _ -> line |> v -- | Push the current line onto the finished lines list and start a new -- line. -pushFLine :: FlattenM () +pushFLine :: FlattenM a () pushFLine = lift $ modify $ \s -> s { fsCompletedLines = fsCompletedLines s |> fsCurLine s , fsCurLine = mempty } -isKnownUser :: T.Text -> FlattenM Bool +isKnownUser :: T.Text -> FlattenM a Bool isKnownUser u = do hSet <- asks flattenHighlightSet let uSet = hUserSet hSet return $ u `Set.member` uSet -isKnownChannel :: T.Text -> FlattenM Bool +isKnownChannel :: T.Text -> FlattenM a Bool isKnownChannel c = do hSet <- asks flattenHighlightSet let cSet = hChannelSet hSet return $ c `Set.member` cSet -flatten :: Inline -> FlattenM () +flatten :: SemEq a => Inline -> FlattenM a () flatten i = case i of EUser u -> do @@ -243,7 +331,10 @@ ENonBreaking is -> do env <- ask - pushFV $ (NonBreaking $ flattenInlineSeq' env is) + ni <- getNextNameIndex + let (ni', s) = flattenInlineSeq' env ni is + pushFV $ NonBreaking s + setNextNameIndex ni' ESoftBreak -> pushFLine ELineBreak -> pushFLine @@ -254,27 +345,27 @@ EEmoji e -> pushFC $ FEmoji e EEditSentinel r -> pushFC $ FEditSentinel r - EEmph es -> withInlineStyle Emph $ mapM_ flatten $ unInlines es - EStrikethrough es -> withInlineStyle Strikethrough $ mapM_ flatten $ unInlines es - EStrong es -> withInlineStyle Strong $ mapM_ flatten $ unInlines es - ECode es -> withInlineStyle Code $ mapM_ flatten $ unInlines es + EEmph es -> withInlineStyle Emph $ flattenInlines es + EStrikethrough es -> withInlineStyle Strikethrough $ flattenInlines es + EStrong es -> withInlineStyle Strong $ flattenInlines es + ECode es -> withInlineStyle Code $ flattenInlines es EPermalink _ _ mLabel -> let label' = fromMaybe (Inlines $ Seq.fromList [EText "post", ESpace, EText "link"]) mLabel - in withInlineStyle Permalink $ mapM_ flatten $ unInlines $ decorateLinkLabel label' + in withInlineStyle Permalink $ flattenInlines $ decorateLinkLabel label' EHyperlink u label@(Inlines ls) -> let label' = if Seq.null ls then Inlines $ Seq.singleton $ EText $ unURL u else label - in withHyperlink u $ mapM_ flatten $ unInlines $ decorateLinkLabel label' + in withHyperlink u $ flattenInlines $ decorateLinkLabel label' EImage u label@(Inlines ls) -> let label' = if Seq.null ls then Inlines $ Seq.singleton $ EText $ unURL u else label - in withHyperlink u $ mapM_ flatten $ unInlines $ decorateLinkLabel label' + in withHyperlink u $ flattenInlines $ decorateLinkLabel label' linkOpenBracket :: Inline linkOpenBracket = EText "<" diff --git a/src/Matterhorn/Draw/RichText/Wrap.hs b/src/Matterhorn/Draw/RichText/Wrap.hs --- a/src/Matterhorn/Draw/RichText/Wrap.hs +++ b/src/Matterhorn/Draw/RichText/Wrap.hs @@ -34,12 +34,12 @@ import Matterhorn.Constants ( editMarking ) -type WrappedLine = Seq FlattenedValue +type WrappedLine a = Seq (FlattenedValue a) -data WrapState = - WrapState { wrapCompletedLines :: Seq WrappedLine +data WrapState a = + WrapState { wrapCompletedLines :: Seq (WrappedLine a) -- ^ The completed lines so far - , wrapCurLine :: WrappedLine + , wrapCurLine :: (WrappedLine a) -- ^ The current line we are accumulating , wrapCurCol :: Int -- ^ The width of wrapCurLine, in columns @@ -47,12 +47,12 @@ -- ^ The maximum allowable width } -type WrapM a = State WrapState a +type WrapM a b = State (WrapState b) a -- | Push a flattened value onto the current line if possible, or add a -- line break and add the inline value to a new line if it would cause -- the current line width to exceed the maximum. -pushValue :: FlattenedValue -> WrapM () +pushValue :: FlattenedValue a -> WrapM () a pushValue i = do let iw = fvWidth i pushThisInline = @@ -69,7 +69,7 @@ -- | Insert a new line break by moving the current accumulating line -- onto the completed lines list and resetting it to empty. -pushLine :: WrapM () +pushLine :: WrapM () a pushLine = do let trimLeadingWhitespace s = case Seq.viewl s of @@ -86,7 +86,7 @@ -- lines wrapped at the specified column. This only returns lines longer -- than the maximum width when those lines have a single inline value -- that cannot be broken down further (such as a long URL). -doLineWrapping :: Int -> Seq FlattenedValue -> Seq WrappedLine +doLineWrapping :: Int -> Seq (FlattenedValue a) -> Seq (WrappedLine a) doLineWrapping maxCols i = result where @@ -99,13 +99,13 @@ -- The widths returned by this function must match the content widths -- rendered by renderFlattenedValue. -fvWidth :: FlattenedValue -> Int +fvWidth :: FlattenedValue a -> Int fvWidth (SingleInline fi) = fiWidth fi fvWidth (NonBreaking rs) = sum $ (sum . fmap fvWidth) <$> rs -- The widths returned by this function must match the content widths -- rendered by renderFlattenedValue. -fiWidth :: FlattenedInline -> Int +fiWidth :: FlattenedInline a -> Int fiWidth fi = case fiValue fi of FText t -> B.textWidth t diff --git a/src/Matterhorn/Draw/SaveAttachmentWindow.hs b/src/Matterhorn/Draw/SaveAttachmentWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/SaveAttachmentWindow.hs @@ -0,0 +1,45 @@ +module Matterhorn.Draw.SaveAttachmentWindow + ( drawSaveAttachmentWindow + ) +where + +import Prelude () +import Matterhorn.Prelude + +import Brick +import Brick.Focus +import Brick.Widgets.Border +import Brick.Widgets.Center +import Brick.Widgets.Edit + +import qualified Data.Text as T + +import Matterhorn.Types +import Matterhorn.Draw.Buttons +import Matterhorn.Themes + + +drawSaveAttachmentWindow :: ChatState -> Widget Name +drawSaveAttachmentWindow st = + centerLayer $ + hLimit maxWindowWidth $ + joinBorders $ + borderWithLabel (withDefAttr clientEmphAttr $ txt "Save Attachment") $ + vBox [ padAll 1 $ + txt "Path: " <+> + (vLimit editorHeight $ + withFocusRing foc (renderEditor drawEditorTxt) ed) + , hBox [ padRight Max $ + padLeft (Pad 1) $ + drawButton foc (AttachmentPathSaveButton tId) "Save" + , padRight (Pad 1) $ + drawButton foc (AttachmentPathCancelButton tId) "Cancel" + ] + ] + where + tId = st^.csCurrentTeamId + editorHeight = 1 + maxWindowWidth = 50 + foc = st^.csCurrentTeam.tsSaveAttachmentDialog.attachmentPathDialogFocus + ed = st^.csCurrentTeam.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 @@ -287,19 +287,19 @@ emph :: Widget a -> Widget a emph = withDefAttr helpEmphAttr -para :: Text -> Widget a +para :: SemEq a => Text -> Widget a para t = padTop (Pad 1) $ renderText t -paraL :: [Text] -> Widget a +paraL :: SemEq a => [Text] -> Widget a paraL = para . mconcat -heading :: Text -> Widget a +heading :: SemEq a => Text -> Widget a heading = padTop (Pad 1) . headingNoPad -headingNoPad :: Text -> Widget a +headingNoPad :: SemEq a => Text -> Widget a headingNoPad t = hCenter $ emph $ renderText t -syntaxHighlightHelp :: [FilePath] -> Widget a +syntaxHighlightHelp :: SemEq a => [FilePath] -> Widget a syntaxHighlightHelp dirs = vBox [ heading "Syntax Highlighting" @@ -321,7 +321,7 @@ "the `syntax/` directory of your Matterhorn distribution." ] -themeHelp :: Widget a +themeHelp :: Widget Name themeHelp = vBox [ heading "Using Themes" , para "Matterhorn provides these built-in color themes:" 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 @@ -63,9 +63,11 @@ let width = Vty.imageWidth (result^.imageL) if isCurrent then - render $ padBottom (Pad 1) $ raw $ result^.imageL + render $ padBottom (Pad 1) $ Widget Fixed Fixed $ return result else - render $ vBox [raw $ result^.imageL, hLimit width hBorder] + render $ vBox [ Widget Fixed Fixed $ return result + , hLimit width hBorder + ] in makeVisible $ decorateTab $ useAttr $ 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 @@ -28,7 +28,7 @@ header <=> urlDisplay where header = (withDefAttr channelHeaderAttr $ vLimit 1 $ - (renderText' Nothing "" (getHighlightSet st) $ + (renderText' Nothing "" (getHighlightSet st) Nothing $ "URLs: " <> (mkChannelName st (st^.csCurrentChannel.ccInfo))) <+> fill ' ') <=> hBorder @@ -42,7 +42,7 @@ hSet = getHighlightSet st - renderItem sel link = + renderItem sel (i, link) = let time = link^.linkTime in attr sel $ vLimit 2 $ (vLimit 1 $ @@ -53,14 +53,14 @@ Just label -> case Seq.null (unInlines label) of True -> emptyWidget - False -> txt ": " <+> renderRichText me hSet Nothing False + False -> txt ": " <+> renderRichText me hSet Nothing False Nothing (Blocks $ Seq.singleton $ Para label) , fill ' ' , renderDate st $ withServerTime time , str " " , renderTime st $ withServerTime time ] ) <=> - (vLimit 1 (renderLinkTarget (link^.linkTarget))) + (vLimit 1 (clickable (ClickableURLListEntry i (link^.linkTarget)) $ renderLinkTarget (link^.linkTarget))) renderLinkTarget (LinkPermalink (TeamURLName tName) pId) = renderText $ "Team: " <> tName <> ", post " <> idString pId diff --git a/src/Matterhorn/Events.hs b/src/Matterhorn/Events.hs --- a/src/Matterhorn/Events.hs +++ b/src/Matterhorn/Events.hs @@ -10,8 +10,10 @@ import Brick import qualified Data.Text as T +import GHC.Exception ( fromException ) import qualified Graphics.Vty as Vty import Lens.Micro.Platform ( (.=), _2, singular, _Just ) +import qualified System.IO.Error as IO import qualified Network.Mattermost.Endpoints as MM import Network.Mattermost.Exceptions ( mattermostErrorMessage ) @@ -24,10 +26,13 @@ import Matterhorn.State.Common import Matterhorn.State.Help import Matterhorn.State.Messages +import Matterhorn.State.Teams ( setTeam ) +import Matterhorn.State.ListOverlay ( listOverlayActivate ) import Matterhorn.Types import Matterhorn.Events.ChannelSelect import Matterhorn.Events.ChannelTopicWindow +import Matterhorn.Events.SaveAttachmentWindow import Matterhorn.Events.DeleteChannelConfirm import Matterhorn.Events.Keybindings import Matterhorn.Events.LeaveChannelConfirm @@ -40,11 +45,12 @@ import Matterhorn.Events.UserListOverlay import Matterhorn.Events.ChannelListOverlay import Matterhorn.Events.ReactionEmojiListOverlay +import Matterhorn.State.Reactions ( toggleReaction ) import Matterhorn.Events.TabbedWindow import Matterhorn.Events.ManageAttachments import Matterhorn.Events.EditNotifyPrefs import Matterhorn.Events.Websocket - +import Matterhorn.State.Links ( openLinkTarget ) onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState) onEvent st ev = runMHEvent st $ do @@ -60,8 +66,20 @@ liftIO $ Vty.refresh vty onBrickEvent (VtyEvent e) = onVtyEvent e -onBrickEvent _ = - return () +onBrickEvent (MouseUp {}) = do + mhLog LogGeneral "MOUSE UP EVENT" + csLastMouseDownEvent .= Nothing +onBrickEvent e@(MouseDown n button modifier clickLoc) = do + mhLog LogGeneral $ T.pack $ "MOUSE EVENT: " <> show (n, button, modifier) + lastClick <- use csLastMouseDownEvent + let shouldHandle = case lastClick of + Nothing -> True + Just (MouseDown prevN _ _ _) -> not $ prevN `semeq` n + _ -> False + when shouldHandle $ do + mhLog LogGeneral "Handling mouse event" + csLastMouseDownEvent .= Just e + onMouseDown n button modifier clickLoc onAppEvent :: MHEvent -> MH () onAppEvent RefreshWebsocketEvent = @@ -129,6 +147,65 @@ postErrorMessage' $ "Could not write log snapshot to " <> T.pack path <> ", error: " <> T.pack err +-- Handle mouse click events. +-- +-- Note that the handler for each case may need to check the application +-- mode before handling the click. This is because some mouse events +-- only make sense when the UI is displaying certain contents. While +-- it's true that we probably wouldn't even get the click events in the +-- first place (because the UI element would only cause a click event +-- to be reported if it was actually rendered), there are cases when we +-- can get clicks on UI elements that *are* clickable even though those +-- clicks don't make sense for the application mode. A concrete example +-- of this is when we display the current channel's contents in one +-- layer, in monochrome, and then display a modal dialog box on top of +-- that. We probably *should* ignore clicks on the lower layer because +-- that's not the mode the application is in, but getting that right +-- could be hard because we'd have to figure out all possible modes +-- where those lower-layer clicks would be nonsensical. We don't bother +-- doing that in the harder cases; instead we just handle the clicks +-- and do what we would ordinarily do, assuming that there's no real +-- harm done. The worst that could happen is that a user could click +-- 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. +onMouseDown :: Name -> Vty.Button -> [Vty.Modifier] -> Location -> MH() +onMouseDown (ClickableChannelListEntry channelId) Vty.BLeft [] _ = do + whenMode Main $ do + resetReturnChannel + setFocus channelId + setMode Main +onMouseDown (ClickableTeamListEntry teamId) Vty.BLeft [] _ = + -- We deliberately handle this event in all modes; this allows us to + -- switch the UI to another team regardless of what state it is in, + -- which is by design since all teams have their own UI states. + setTeam teamId +onMouseDown (ClickableURLInMessage _ _ t) Vty.BLeft [] _ = + void $ openLinkTarget t +onMouseDown (ClickableURL _ _ t) Vty.BLeft [] _ = + void $ openLinkTarget t +onMouseDown (ClickableUsernameInMessage _ _ username) Vty.BLeft [] _ = + changeChannelByName $ userSigil <> username +onMouseDown (ClickableUsername _ _ username) Vty.BLeft [] _ = + changeChannelByName $ userSigil <> username +onMouseDown (ClickableURLListEntry _ t) Vty.BLeft [] _ = + -- Only handle URL list entry clicks when viewing the URL list + whenMode UrlSelect $ do + void $ openLinkTarget t +onMouseDown (ChannelSelectEntry match) Vty.BLeft [] _ = + whenMode ChannelSelect $ do + setMode Main + setFocus $ channelListEntryChannelId $ matchEntry match +onMouseDown (ClickableReactionInMessage pId t uIds) Vty.BLeft [] _ = + void $ toggleReaction pId t uIds +onMouseDown (ClickableReaction pId t uIds) Vty.BLeft [] _ = + void $ toggleReaction pId t uIds +onMouseDown (ReactionEmojiListOverlayEntry val) Vty.BLeft [] _ = + whenMode ReactionEmojiListOverlay $ do + listOverlayActivate (csCurrentTeam.tsReactionEmojiListOverlay) val +onMouseDown _ _ _ _ = + return () + formatError :: MHError -> T.Text formatError (GenericError msg) = msg @@ -155,6 +232,19 @@ let knownTopics = (" - " <>) <$> helpTopicName <$> helpTopics in "Unknown help topic: `" <> topic <> "`. " <> (T.unlines $ "Available topics are:" : knownTopics) +formatError (AttachmentException e) = + case fromException e of + Just (ioe :: IO.IOError) -> + if IO.isDoesNotExistError ioe + then "Error attaching, file does not exist!" + else if IO.isPermissionError ioe + then "Error attaching, lacking permissions to read file!" + else "Unable to attach the requested file. Check that it exists and has proper permissions." + Nothing -> "Unknown error attaching file!\n" <> + "Please report this error at https://github.com/matterhorn-chat/matterhorn/issues" + -- this case shouldn't be reached +formatError (BadAttachmentPath msg) = + msg formatError (AsyncErrEvent e) = "An unexpected error has occurred! The exception encountered was:\n " <> T.pack (show e) <> @@ -203,6 +293,7 @@ ManageAttachmentsBrowseFiles -> onEventManageAttachments EditNotifyPrefs -> void . onEventEditNotifyPrefs ChannelTopicWindow -> onEventChannelTopicWindow + SaveAttachmentWindow _ -> onEventSaveAttachmentWindow globalKeybindings :: KeyConfig -> KeyHandlerMap globalKeybindings = mkKeybindings globalKeyHandlers 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 @@ -178,6 +178,7 @@ ToggleExpandedChannelTopicsEvent -> [ fn 3 ] SelectNextTabEvent -> [ key '\t' ] SelectPreviousTabEvent -> [ kb Vty.KBackTab ] + SaveAttachmentEvent -> [ key 's' ] LoadMoreEvent -> [ ctrl (key 'b') ] ScrollUpEvent -> [ kb Vty.KUp ] ScrollDownEvent -> [ kb Vty.KDown ] @@ -225,6 +226,17 @@ EditorHomeEvent -> [ kb Vty.KHome ] EditorEndEvent -> [ kb Vty.KEnd ] EditorYankEvent -> [ ctrl (key 'y') ] + FileBrowserBeginSearchEvent -> [ key '/' ] + FileBrowserSelectEnterEvent -> [ kb Vty.KEnter ] + FileBrowserSelectCurrentEvent -> [ kb (Vty.KChar ' ') ] + FileBrowserListPageUpEvent -> [ ctrl (key 'b'), kb Vty.KPageUp ] + FileBrowserListPageDownEvent -> [ ctrl (key 'f'), kb Vty.KPageDown ] + FileBrowserListHalfPageUpEvent -> [ ctrl (key 'u') ] + FileBrowserListHalfPageDownEvent -> [ ctrl (key 'd') ] + FileBrowserListTopEvent -> [ key 'g', kb Vty.KHome ] + FileBrowserListBottomEvent -> [ key 'G', kb Vty.KEnd ] + FileBrowserListNextEvent -> [ key 'j', ctrl (key 'n'), kb Vty.KDown ] + FileBrowserListPrevEvent -> [ key 'k', ctrl (key 'p'), kb Vty.KUp ] FormSubmitEvent -> [ kb Vty.KEnter ] NextTeamEvent -> [ ctrl (kb Vty.KRight) ] PrevTeamEvent -> [ ctrl (kb Vty.KLeft) ] 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 @@ -12,10 +12,8 @@ import Prelude () import Matterhorn.Prelude -import qualified Control.Exception as E import qualified Brick.Widgets.FileBrowser as FB import qualified Brick.Widgets.List as L -import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Vector as Vector import qualified Graphics.Vty as V @@ -69,6 +67,40 @@ cancelAttachmentBrowse , mkKb AttachmentOpenEvent "Open the selected file using the URL open command" openSelectedBrowserEntry + , mkKb FileBrowserBeginSearchEvent "Begin search for name in list" $ + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserBeginSearch + , mkKb FileBrowserSelectEnterEvent "Select file or enter directory" $ do + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserSelectEnter + withFileBrowser (tryAddAttachment . FB.fileBrowserSelection) + , mkKb FileBrowserSelectCurrentEvent "Select file" $ + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserSelectCurrent + , mkKb FileBrowserListPageUpEvent "Move cursor one page up" $ + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserListPageUp + , mkKb FileBrowserListPageDownEvent "Move cursor one page down" $ + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserListPageDown + , mkKb FileBrowserListHalfPageUpEvent "Move cursor one-half page up" $ + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserListHalfPageUp + , mkKb FileBrowserListHalfPageDownEvent "Move cursor one-half page down" $ + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserListHalfPageDown + , mkKb FileBrowserListTopEvent "Move cursor to top of list" $ + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserListTop + , mkKb FileBrowserListBottomEvent "Move cursor to bottom of list" $ + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserListBottom + , mkKb FileBrowserListNextEvent "Move cursor down" $ + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserListNext + , mkKb FileBrowserListPrevEvent "Move cursor up" $ + mhHandleEventLensed' (csCurrentTeam.tsEditState.unsafeCedFileBrowser) + FB.actionFileBrowserListPrev ] withFileBrowser :: ((FB.FileBrowser Name) -> MH ()) -> MH () @@ -127,38 +159,11 @@ handleFileBrowserEvent :: V.Event -> MH () handleFileBrowserEvent e = do - let fbHandle ev = sequence . (fmap (FB.handleFileBrowserEvent ev)) - mhHandleEventLensed (csCurrentTeam.tsEditState.cedFileBrowser) fbHandle e - - withFileBrowser $ \b -> do + let fbHandle ev = sequence . (fmap (FB.handleFileBrowserEvent ev)) + mhHandleEventLensed (csCurrentTeam.tsEditState.cedFileBrowser) fbHandle e -- TODO: Check file browser exception state - let entries = FB.fileBrowserSelection b - forM_ entries $ \entry -> do - -- Is the entry already present? If so, ignore the selection. - es <- use (csCurrentTeam.tsEditState.cedAttachmentList.L.listElementsL) - let matches = (== (FB.fileInfoFilePath entry)) . - FB.fileInfoFilePath . - attachmentDataFileInfo - case Vector.find matches es of - Just _ -> return () - Nothing -> do - let path = FB.fileInfoFilePath entry - readResult <- liftIO $ E.try $ BS.readFile path - case readResult of - Left (_::E.SomeException) -> - -- TODO: report the error - return () - Right bytes -> do - let a = AttachmentData { attachmentDataFileInfo = entry - , attachmentDataBytes = bytes - } - oldIdx <- use (csCurrentTeam.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 - - when (not $ null entries) $ setMode Main + withFileBrowser $ \b -> + tryAddAttachment $ FB.fileBrowserSelection b deleteSelectedAttachment :: MH () deleteSelectedAttachment = do 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 @@ -1,4 +1,10 @@ -module Matterhorn.Events.MessageSelect where +module Matterhorn.Events.MessageSelect + ( messageSelectKeybindings + , messageSelectKeyHandlers + , onEventMessageSelect + , onEventMessageSelectDeleteConfirm + ) +where import Prelude () import Matterhorn.Prelude diff --git a/src/Matterhorn/Events/SaveAttachmentWindow.hs b/src/Matterhorn/Events/SaveAttachmentWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Events/SaveAttachmentWindow.hs @@ -0,0 +1,65 @@ +module Matterhorn.Events.SaveAttachmentWindow + ( onEventSaveAttachmentWindow + ) +where + +import Prelude () +import Matterhorn.Prelude + +import qualified Control.Exception as E + +import Brick.Focus +import Brick.Widgets.Edit ( handleEditorEvent, getEditContents ) +import qualified Data.Text as T +import Lens.Micro.Platform ( (%=) ) +import qualified Graphics.Vty as Vty + +import Matterhorn.Types +import Matterhorn.State.Common ( postInfoMessage, fetchFileAtPath + , doAsyncWith, AsyncPriority(Normal) + , postErrorMessage' + ) + + +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) + session <- getSession + mode <- use (csCurrentTeam.tsMode) + + let SaveAttachmentWindow link = mode + LinkFileId fId = link^.linkTarget + save = do + ed <- use (csCurrentTeam.tsSaveAttachmentDialog.attachmentPathEditor) + let path = T.unpack $ T.strip $ T.concat $ getEditContents ed + + when (not $ null path) $ do + doAsyncWith Normal $ do + result <- E.try $ fetchFileAtPath fId session path + return $ Just $ do + case result of + Left (e::E.SomeException) -> + postErrorMessage' $ T.pack $ "Error saving to " <> path <> ": " <> show e + Right () -> + postInfoMessage $ T.pack $ "Attachment saved to " <> path + setMode 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) + case focusGetCurrent f of + Just (AttachmentPathEditor {}) -> + mhHandleEventLensed (csCurrentTeam.tsSaveAttachmentDialog.attachmentPathEditor) + handleEditorEvent e + _ -> + return () 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 @@ -8,6 +8,7 @@ import Matterhorn.Events.Keybindings import Matterhorn.State.UrlSelect +import Matterhorn.State.SaveAttachmentWindow import Matterhorn.Types @@ -24,6 +25,9 @@ [ staticKb "Open the selected URL, if any" (Vty.EvKey Vty.KEnter []) $ openSelectedURL + + , mkKb SaveAttachmentEvent "Save the selected attachment" + openSaveAttachmentWindow , mkKb CancelEvent "Cancel URL selection" stopUrlSelect 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 @@ -214,7 +214,12 @@ mhLog LogGeneral $ T.pack $ "WMTeamDeleted event: " <> show we - WMUserUpdated -> return () + WMUserUpdated + | Just user <- wepUser (weData we) -> do + handleUserUpdated user + cid <- use $ csCurrentChannel . ccInfo . cdChannelId + refreshChannelById cid + | otherwise -> return () -- We deliberately ignore these events: WMChannelCreated -> return () diff --git a/src/Matterhorn/Login.hs b/src/Matterhorn/Login.hs --- a/src/Matterhorn/Login.hs +++ b/src/Matterhorn/Login.hs @@ -87,7 +87,7 @@ , ciPassword, ciUsername, ciHostname, ciUrlPath , ciPort, ciType, AuthenticationException(..) , LogManager, LogCategory(..), ioLogWithManager - , ciAccessToken + , ciAccessToken, SemEq(..) ) @@ -98,6 +98,9 @@ | Password | AccessToken deriving (Ord, Eq, Show) + +instance SemEq Name where + semeq = (==) -- | The result of an authentication attempt. data LoginAttempt = 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 @@ -1,21 +1,29 @@ +{-# LANGUAGE LambdaCase #-} module Matterhorn.State.Attachments ( showAttachmentList , resetAttachmentList , showAttachmentFileBrowser + , attachFileByPath + , tryAddAttachment + , tryReadAttachment ) where import Prelude () import Matterhorn.Prelude -import qualified Control.Exception as E -import Data.Either ( isRight ) -import System.Directory ( doesDirectoryExist, getDirectoryContents ) -import Data.Bool ( bool ) import Brick ( vScrollToBeginning, viewportScroll ) import qualified Brick.Widgets.List as L import qualified Brick.Widgets.FileBrowser as FB -import Lens.Micro.Platform ( (.=) ) +import qualified Control.Exception as E +import Data.Bool ( bool ) +import qualified Data.ByteString as BS +import Data.Either ( isRight ) +import Data.Text ( unpack ) +import qualified Data.Vector as Vector +import GHC.Exception ( toException ) +import Lens.Micro.Platform ( (.=), (%=) ) +import System.Directory ( doesDirectoryExist, doesFileExist, getDirectoryContents ) import Matterhorn.Types @@ -54,3 +62,54 @@ browser <- liftIO $ Just <$> FB.newFileBrowser FB.selectNonDirectories (AttachmentFileBrowser tId) filePath csCurrentTeam.tsEditState.cedFileBrowser .= browser setMode ManageAttachmentsBrowseFiles + +attachFileByPath :: Text -> MH () +attachFileByPath 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] + +checkPathIsFile :: FB.FileInfo -> MH Bool +checkPathIsFile = liftIO . doesFileExist . FB.fileInfoFilePath + +tryAddAttachment :: [FB.FileInfo] -> MH () +tryAddAttachment entries = do + forM_ entries $ \entry -> do + isFile <- checkPathIsFile entry + if not isFile + then mhError (BadAttachmentPath + "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) + let matches = (== FB.fileInfoFilePath entry) . + FB.fileInfoFilePath . + attachmentDataFileInfo + case Vector.find matches es of + Just _ -> return () + Nothing -> do + tryReadAttachment entry >>= \case + Right a -> do + oldIdx <- use (csCurrentTeam.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 + Left e -> mhError $ AttachmentException e + + when (not $ null entries) $ setMode Main + +tryReadAttachment :: FB.FileInfo -> MH (Either E.SomeException AttachmentData) +tryReadAttachment fi = do + let path = FB.fileInfoFilePath fi + readResult <- liftIO $ E.try $ BS.readFile path + case readResult of + Right bytes -> do + return $ Right $ + AttachmentData { attachmentDataFileInfo = fi + , attachmentDataBytes = bytes + } + Left e -> return $ Left e 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 @@ -143,11 +143,17 @@ -- We don't think this command makes sense for Matterhorn. , "logout" + , "remove" + , "msg" + -- We provide a version of /leave with confirmation. , "leave" -- We provide our own join UI. , "join" + + -- We provide our own search UI. + , "search" -- We provide our own version of this command that opens our own -- help UI. 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 @@ -84,7 +84,8 @@ config <- use (csResources.crConfiguration) let zl = mkChannelZipperList now config tId cconfig prefs cs us - csTeam(tId).tsFocus %= Z.updateList zl + compareEntries mOld new = (channelListEntryChannelId <$> mOld) == Just (channelListEntryChannelId new) + csTeam(tId).tsFocus %= Z.updateListBy compareEntries zl -- If the zipper rebuild caused the current channel to change, such -- as when the previously-focused channel was removed, we need to 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 @@ -76,9 +76,12 @@ if patTy == Just PrefixNonDMOnly then Nothing else (chanNameMatches e . displayName) uInfo - matches e@(CLChannel cId) = findChannelById cId (st^.csChannels) >>= chanMatches e - matches e@(CLUserDM _ uId) = userById uId st >>= userMatches e - matches e@(CLGroupDM cId) = findChannelById cId (st^.csChannels) >>= groupChanMatches e + matches e = + let cId = channelListEntryChannelId e + in case channelListEntryType e of + CLChannel -> findChannelById cId (st^.csChannels) >>= chanMatches e + CLUserDM uId -> userById uId st >>= userMatches e + CLGroupDM -> findChannelById cId (st^.csChannels) >>= groupChanMatches e preserveFocus Nothing _ = False preserveFocus (Just m) m2 = matchEntry m == matchEntry m2 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 @@ -46,6 +46,7 @@ , toggleExpandedChannelTopics , updateChannelNotifyProps , renameChannelUrl + , toggleChannelFavoriteStatus ) where @@ -589,6 +590,24 @@ False -> do csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing + | Just f <- preferenceToFavoriteChannelPreference pref -> do + updateSidebar Nothing + + -- We need to check on whether this preference was to show a + -- channel and, if so, whether it was the one we attempted to + -- switch to (thus triggering the preference change). If so, + -- we need to switch to it now. + let cId = favoriteChannelId f + case favoriteChannelShow f of + True -> do + pending <- checkPendingChannelChange cId + case pending of + Just mAct -> do + setFocus cId + fromMaybe (return ()) mAct + Nothing -> return () + False -> do + csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing | otherwise -> return () refreshChannelById :: ChannelId -> MH () @@ -755,7 +774,7 @@ -- for the next candidate channel. Z.findRight (\e -> let cId = channelListEntryChannelId e - in hasUnread st cId && (cId /= st^.csCurrentChannelId(st^.csCurrentTeamId))) + in channelListEntryUnread e && (cId /= st^.csCurrentChannelId(st^.csCurrentTeamId))) getNextUnreadUserOrChannel :: ChatState -> Zipper a ChannelListEntry @@ -763,9 +782,9 @@ getNextUnreadUserOrChannel st z = -- Find the next unread channel, prefering direct messages let cur = st^.csCurrentChannelId(st^.csCurrentTeamId) - matches e = entryIsDMEntry e && isFresh (channelListEntryChannelId e) - isFresh c = hasUnread st c && (c /= cur) - in fromMaybe (Z.findRight (isFresh . channelListEntryChannelId) z) + matches e = entryIsDMEntry e && isFresh e + isFresh e = channelListEntryUnread e && (channelListEntryChannelId e /= cur) + in fromMaybe (Z.findRight isFresh z) (Z.maybeFindRight matches z) leaveCurrentChannel :: MH () @@ -988,34 +1007,39 @@ -- but valid user channel. changeChannelByName :: Text -> MH () changeChannelByName name = do + myId <- gets myUserId mCId <- gets (channelIdByChannelName name) mDMCId <- gets (channelIdByUsername name) withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do - let err = mhError $ AmbiguousName name - case (mCId, mDMCId) of - (Nothing, Nothing) -> - case foundUser of - -- We know about the user but there isn't already a DM - -- channel, so create one. - Just user -> createOrFocusDMChannel user Nothing - -- There were no matches of any kind. - Nothing -> mhError $ NoSuchChannel name - (Just cId, Nothing) - -- We matched a channel and there was an explicit sigil, so we - -- don't care about the username match. - | normalChannelSigil `T.isPrefixOf` name -> setFocus cId - -- We matched both a channel and a user, even though there is - -- no DM channel. - | Just _ <- foundUser -> err - -- We matched a channel only. - | otherwise -> setFocus cId - (Nothing, Just cId) -> - -- We matched a DM channel only. - setFocus cId - (Just _, Just _) -> - -- We matched both a channel and a DM channel. - err + if (_uiId <$> foundUser) == Just myId + then return () + else do + setMode 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 + -- There were no matches of any kind. + Nothing -> mhError $ NoSuchChannel name + (Just cId, Nothing) + -- We matched a channel and there was an explicit sigil, so we + -- don't care about the username match. + | normalChannelSigil `T.isPrefixOf` name -> setFocus cId + -- We matched both a channel and a user, even though there is + -- no DM channel. + | Just _ <- foundUser -> err + -- We matched a channel only. + | otherwise -> setFocus cId + (Nothing, Just cId) -> + -- We matched a DM channel only. + setFocus cId + (Just _, Just _) -> + -- We matched both a channel and a DM channel. + err setChannelTopic :: Text -> MH () setChannelTopic msg = do @@ -1065,3 +1089,26 @@ Just tId -> mh $ invalidateCacheEntry $ ChannelSidebar tId csChannel(cId).ccInfo.cdNotifyProps .= notifyProps + +toggleChannelFavoriteStatus :: MH () +toggleChannelFavoriteStatus = 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 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 @@ -4,7 +4,8 @@ openFilePath , openWithOpener , runLoggedCommand - , prepareAttachment + , fetchFile + , fetchFileAtPath -- * Posts , installMessagesFromPosts @@ -30,7 +31,6 @@ import Brick.Main ( invalidateCacheEntry ) import Control.Concurrent ( MVar, putMVar, forkIO ) -import Control.Concurrent.Async ( concurrently ) import qualified Control.Concurrent.STM as STM import Control.Exception ( SomeException, try ) import qualified Data.ByteString as BS @@ -288,20 +288,36 @@ error $ "BUG: createProcess returned unexpected result, report this at " <> "https://github.com/matterhorn-chat/matterhorn" -prepareAttachment :: FileId -> Session -> IO String -prepareAttachment fId sess = do +-- | Given a file ID and server session, fetch the file into a temporary +-- location and return its path. The caller is responsible for deleting +-- the file. +fetchFile :: FileId -> Session -> IO String +fetchFile fId sess = do -- The link is for an attachment, so fetch it and then -- open the local copy. - - (info, contents) <- concurrently (mmGetMetadataForFile fId sess) (mmGetFile fId sess) + info <- mmGetMetadataForFile fId sess cacheDir <- getUserCacheDir xdgName + let dir = cacheDir "files" T.unpack (idString fId) + filename = T.unpack (fileInfoName info) + fullPath = dir filename - let dir = cacheDir "files" T.unpack (idString fId) - fname = dir T.unpack (fileInfoName info) + fetchFileAtPath fId sess fullPath + return fullPath - createDirectoryIfMissing True dir - BS.writeFile fname contents - return fname +-- | Given a file ID and server session, fetch the file and save it to +-- the specified destination path. The destination path must refer to +-- the path to the file itself, not its parent directory. This function +-- will create only the parent directory in the specified path; it will +-- not create all path entries recursively. If the file already exists, +-- this function will overwrite the file. +-- +-- The caller is responsible for catching all exceptions. +fetchFileAtPath :: FileId -> Session -> FilePath -> IO () +fetchFileAtPath fId sess fullPath = do + contents <- mmGetFile fId sess + let dir = takeDirectory fullPath + createDirectoryIfMissing False dir + BS.writeFile fullPath contents removeEmoteFormatting :: T.Text -> T.Text removeEmoteFormatting t 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 @@ -234,11 +234,14 @@ mode <- use (csTeam(tId).tsEditState.cedEditMode) sendMessage cId mode content $ F.toList attachments + -- 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 + -- Reset the autocomplete UI resetAutocomplete - -- Empty the attachment list - resetAttachmentList -- Reset the edit mode *after* handling the input so that the input -- handler can tell whether we're editing, replying, etc. diff --git a/src/Matterhorn/State/Links.hs b/src/Matterhorn/State/Links.hs --- a/src/Matterhorn/State/Links.hs +++ b/src/Matterhorn/State/Links.hs @@ -19,5 +19,5 @@ session <- getSession case target of LinkURL url -> openWithOpener (return $ T.unpack $ unURL url) - LinkFileId fId -> openWithOpener (liftIO $ prepareAttachment fId session) + LinkFileId fId -> openWithOpener (liftIO $ fetchFile fId session) LinkPermalink _ pId -> jumpToPost pId >> return True 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 @@ -1,6 +1,7 @@ {-# LANGUAGE RankNTypes #-} module Matterhorn.State.ListOverlay ( listOverlayActivateCurrent + , listOverlayActivate , listOverlaySearchString , listOverlayMove , exitListOverlay @@ -34,12 +35,17 @@ mItem <- L.listSelectedElement <$> use (which.listOverlaySearchResults) case mItem of Nothing -> return () - Just (_, val) -> do - handler <- use (which.listOverlayEnterHandler) - activated <- handler val - if activated - then setMode Main - else return () + Just (_, val) -> listOverlayActivate 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 + handler <- use (which.listOverlayEnterHandler) + activated <- handler val + if activated + then setMode Main + else return () -- | Get the current search string for the specified overlay. listOverlaySearchString :: Lens' ChatState (ListOverlayState a b) -> MH Text 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 @@ -27,6 +27,7 @@ import Prelude () import Matterhorn.Prelude +import Brick ( invalidateCache ) import Brick.Widgets.Edit ( applyEdit ) import Data.Text.Zipper ( clearZipper, insertMany ) import Lens.Micro.Platform @@ -62,6 +63,11 @@ 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 + -- 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 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 @@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-} + module Matterhorn.State.Messages ( PostToAdd(..) , addDisconnectGaps @@ -24,6 +25,8 @@ import Brick.Main ( getVtyHandle, invalidateCacheEntry, invalidateCache ) import qualified Brick.Widgets.FileBrowser as FB import Control.Exception ( SomeException, try ) +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set @@ -665,8 +668,36 @@ -- only available in websocket events (and then provided to this -- constructor). -runNotifyCommand :: Post -> Bool -> MH () -runNotifyCommand post mentioned = do +encodeToJSONstring :: A.ToJSON a => a -> String +encodeToJSONstring a = BL8.unpack $ A.encode a + +-- Notification Version 2 payload definition +data NotificationV2 = NotificationV2 + { version :: Int + , message :: Text + , mention :: Bool + , from :: Text + } deriving (Show) +instance A.ToJSON NotificationV2 where + toJSON (NotificationV2 vers msg mentioned sender) = + A.object [ "version" A..= vers + , "message" A..= msg + , "mention" A..= mentioned + , "from" A..= sender + ] + +-- We define a notifyGetPayload for each notification version. +notifyGetPayload :: NotificationVersion -> ChatState -> Post -> Bool -> Maybe String +notifyGetPayload NotifyV1 _ _ _ = do return "" +notifyGetPayload NotifyV2 st post mentioned = do + let notification = NotificationV2 2 msg mentioned sender + return (encodeToJSONstring notification) + where + msg = sanitizeUserText $ postMessage post + sender = maybePostUsername st post + +handleNotifyCommand :: Post -> Bool -> NotificationVersion -> MH () +handleNotifyCommand post mentioned NotifyV1 = do outputChan <- use (csResources.crSubprocessLog) st <- use id notifyCommand <- use (csResources.crConfiguration.configActivityNotifyCommandL) @@ -680,6 +711,24 @@ runLoggedCommand outputChan (T.unpack cmd) [notified, sender, messageString] Nothing Nothing return Nothing +handleNotifyCommand post mentioned NotifyV2 = do + outputChan <- use (csResources.crSubprocessLog) + st <- use id + let payload = notifyGetPayload NotifyV2 st post mentioned + notifyCommand <- use (csResources.crConfiguration.configActivityNotifyCommandL) + case notifyCommand of + Nothing -> return () + Just cmd -> + doAsyncWith Preempt $ do + runLoggedCommand outputChan (T.unpack cmd) [] payload Nothing + return Nothing + +runNotifyCommand :: Post -> Bool -> MH () +runNotifyCommand post mentioned = do + notifyVersion <- use (csResources.crConfiguration.configActivityNotifyVersionL) + case notifyVersion of + NotifyV1 -> handleNotifyCommand post mentioned NotifyV1 + NotifyV2 -> handleNotifyCommand post mentioned NotifyV2 maybePostUsername :: ChatState -> Post -> T.Text maybePostUsername st p = 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 @@ -22,13 +22,12 @@ import Lens.Micro.Platform ( to ) import Network.Mattermost.Types -import Network.Mattermost.Endpoints ( mmPostReaction, mmDeleteReaction ) import Matterhorn.Emoji import Matterhorn.State.ListOverlay import Matterhorn.State.MessageSelect -import Matterhorn.State.Async import Matterhorn.Types +import Matterhorn.State.Reactions ( updateReaction ) enterReactionEmojiListOverlayMode :: MH () @@ -45,9 +44,6 @@ enterHandler :: (Bool, T.Text) -> MH Bool enterHandler (mine, e) = do - session <- getSession - myId <- gets myUserId - selectedMessage <- use (to getSelectedMessage) case selectedMessage of Nothing -> return False @@ -55,15 +51,7 @@ case m^.mOriginalPost of Nothing -> return False Just p -> do - case mine of - False -> - doAsyncWith Preempt $ do - mmPostReaction (postId p) myId e session - return Nothing - True -> - doAsyncWith Preempt $ do - mmDeleteReaction (postId p) myId e session - return Nothing + updateReaction (postId p) e (not mine) return True fetchResults :: UserId diff --git a/src/Matterhorn/State/Reactions.hs b/src/Matterhorn/State/Reactions.hs --- a/src/Matterhorn/State/Reactions.hs +++ b/src/Matterhorn/State/Reactions.hs @@ -2,6 +2,8 @@ ( asyncFetchReactionsForPost , addReactions , removeReaction + , updateReaction + , toggleReaction ) where @@ -22,6 +24,8 @@ import Matterhorn.Types +-- | Queue up a fetch for the reactions of the specified post in the +-- specified channel. asyncFetchReactionsForPost :: ChannelId -> Post -> MH () asyncFetchReactionsForPost cId p | not (p^.postHasReactionsL) = return () @@ -29,24 +33,63 @@ (\s _ -> fmap toList (mmGetReactionsForPost (p^.postIdL) s)) (\_ rs -> Just $ addReactions cId rs) +-- | Add the specified reactions returned by the server to the relevant +-- posts in the specified channel. This should only be called in +-- response to a server API request or event. If you want to add +-- reactions to a post, start by calling @mmPostReaction@. We also +-- invalidate the cache for any rendered message corresponding to the +-- incoming reactions. addReactions :: ChannelId -> [Reaction] -> MH () addReactions cId rs = do mh $ invalidateCacheEntry $ ChannelMessages cId csChannel(cId).ccContents.cdMessages %= fmap upd let mentions = S.fromList $ UserIdMention <$> reactionUserId <$> rs fetchMentionedUsers mentions + invalidateRenderCache where upd msg = msg & mReactions %~ insertAll (msg^.mMessageId) insert mId r | mId == Just (MessagePostId (r^.reactionPostIdL)) = Map.insertWith S.union (r^.reactionEmojiNameL) (S.singleton $ r^.reactionUserIdL) | otherwise = id insertAll mId msg = foldr (insert mId) msg rs + invalidateRenderCache = do + let cacheIds = map cacheIdOf rs + mh $ mapM_ invalidateCacheEntry cacheIds + cacheIdOf r = RenderedMessage $ MessagePostId (r^.reactionPostIdL) +-- | Remove the specified reaction from its message in the specified +-- channel. This should only be called in response to a server event +-- instructing us to remove the reaction. If you want to trigger such an +-- event, use @updateReaction@. We also invalidate the cache for any +-- rendered message corresponding to the removed reaction. removeReaction :: Reaction -> ChannelId -> MH () removeReaction r cId = do mh $ invalidateCacheEntry $ ChannelMessages cId csChannel(cId).ccContents.cdMessages %= fmap upd + invalidateRenderCache where upd m | m^.mMessageId == Just (MessagePostId $ r^.reactionPostIdL) = m & mReactions %~ (Map.alter delReaction (r^.reactionEmojiNameL)) | otherwise = m delReaction mUs = S.delete (r^.reactionUserIdL) <$> mUs + invalidateRenderCache = + mh $ invalidateCacheEntry $ RenderedMessage $ MessagePostId (r^.reactionPostIdL) + +-- | Set or unset a reaction on a post. +updateReaction :: PostId -> Text -> Bool -> MH () +updateReaction pId text value = do + session <- getSession + myId <- gets myUserId + if value + then doAsyncWith Preempt $ do + mmPostReaction pId myId text session + return Nothing + else doAsyncWith Preempt $ do + mmDeleteReaction pId myId text session + return Nothing + +-- | Toggle a reaction on a post. +toggleReaction :: PostId -> Text -> Set UserId -> MH () +toggleReaction pId text uIds = do + myId <- gets myUserId + let current = myId `S.member` uIds + updateReaction pId text (not current) diff --git a/src/Matterhorn/State/SaveAttachmentWindow.hs b/src/Matterhorn/State/SaveAttachmentWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/State/SaveAttachmentWindow.hs @@ -0,0 +1,41 @@ +module Matterhorn.State.SaveAttachmentWindow + ( openSaveAttachmentWindow + ) +where + +import Prelude () +import Matterhorn.Prelude +import Brick.Widgets.List ( listSelectedElement ) + +import Lens.Micro.Platform ( (.=), to ) + +import Network.Mattermost.Types ( fileInfoName ) +import Network.Mattermost.Endpoints ( mmGetMetadataForFile ) + +import Matterhorn.Types +import Matterhorn.State.Common + + +-- | If the currently selected link in the URL list is for an +-- attachment, open a window to get the user to provide a path to which +-- 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) + 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 + _ -> + -- 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 @@ -10,6 +10,7 @@ import Brick.BChan ( newBChan ) import Brick.Themes ( themeToAttrMap, loadCustomizations ) import qualified Control.Concurrent.STM as STM +import Data.Either ( fromRight ) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import Data.Maybe ( fromJust ) @@ -30,7 +31,7 @@ import Matterhorn.State.Teams ( buildTeamState ) import Matterhorn.State.Setup.Threads import Matterhorn.Themes -import Matterhorn.TimeUtils ( lookupLocalTimeZone ) +import Matterhorn.TimeUtils ( lookupLocalTimeZone, utcTimezone ) import Matterhorn.Types import Matterhorn.Types.Common import Matterhorn.Emoji @@ -186,7 +187,8 @@ let session = getResourceSession cr requestChan = cr^.crRequestQueue - tz <- lookupLocalTimeZone + tz <- fromRight utcTimezone <$> lookupLocalTimeZone + hist <- do result <- readHistory case result of 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 @@ -139,15 +139,24 @@ timezoneMonitor prevTz = do threadDelay timezoneMonitorSleepInterval - newTz <- lookupLocalTimeZone - when (newTz /= prevTz) $ - STM.atomically $ STM.writeTChan requestChan $ do - return $ Just $ do - timeZone .= newTz - mh invalidateCache + newTzResult <- lookupLocalTimeZone + nextTz <- case newTzResult of + Left e -> do + STM.atomically $ STM.writeTChan requestChan $ do + return $ Just $ do + mhLog LogGeneral $ T.pack $ "Could not load time zone information: " <> show e + return prevTz + Right newTz -> do + when (newTz /= prevTz) $ + STM.atomically $ STM.writeTChan requestChan $ do + return $ Just $ do + timeZone .= newTz + mh invalidateCache - timezoneMonitor newTz + return newTz + timezoneMonitor nextTz + void $ forkIO (timezoneMonitor tz) maybeStartSpellChecker :: Config -> BChan MHEvent -> IO (Maybe (Aspell, IO ())) @@ -364,4 +373,5 @@ , "resource vanished" `isInfixOf` eStr , "timeout" `isInfixOf` eStr , "partial packet" `isInfixOf` eStr + , "No route to host" `isInfixOf` eStr ] 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 @@ -7,13 +7,14 @@ , buildTeamState , moveCurrentTeamLeft , moveCurrentTeamRight + , setTeam ) where import Prelude () import Matterhorn.Prelude -import Brick.Main ( invalidateCache ) +import Brick.Main ( invalidateCache, hScrollToBeginning, viewportScroll ) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Time.Clock ( getCurrentTime ) @@ -45,11 +46,22 @@ prevTeam :: MH () prevTeam = setTeamFocusWith Z.left +-- | Set the current team directly +setTeam :: TeamId -> MH () +setTeam tId = setTeamFocusWith $ Z.findRight (== tId) + -- | Change the selected team with the specified team zipper -- transformation. This function also takes care of book-keeping -- necessary during team switching. setTeamFocusWith :: (Z.Zipper () TeamId -> Z.Zipper () TeamId) -> MH () setTeamFocusWith f = do + -- Before we leave this team to view another one, indicate that + -- we've viewed the current team's currently-selected channel so + -- that this team doesn't get left with an unread indicator once we + -- are looking at the other team. We do this when switching channels + -- within a team in the same way. + updateViewed True + csTeamZipper %= f postChangeTeamCommon @@ -58,6 +70,7 @@ postChangeTeamCommon = do updateViewed False fetchVisibleIfNeeded + mh $ hScrollToBeginning (viewportScroll TeamList) -- | Fetch the specified team and add it to the application state. -- 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 @@ -22,9 +22,10 @@ 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) urls 2) + csCurrentTeam.tsUrlList .= (listMoveTo (length urls - 1) $ list (UrlList tId) urlsWithIndexes 2) stopUrlSelect :: MH () stopUrlSelect = setMode Main @@ -34,7 +35,7 @@ selected <- use (csCurrentTeam.tsUrlList.to listSelectedElement) case selected of Nothing -> setMode Main - Just (_, link) -> do + Just (_, (_, link)) -> do opened <- openLinkTarget (link^.linkTarget) when (not opened) $ do mhError $ ConfigOptionMissing "urlOpenCommand" diff --git a/src/Matterhorn/State/Users.hs b/src/Matterhorn/State/Users.hs --- a/src/Matterhorn/State/Users.hs +++ b/src/Matterhorn/State/Users.hs @@ -2,6 +2,7 @@ module Matterhorn.State.Users ( handleNewUsers , handleTypingUser + , handleUserUpdated , withFetchedUser , withFetchedUserMaybe ) @@ -45,6 +46,14 @@ withFetchedUser (UserFetchById uId) $ const $ do ts <- liftIO getCurrentTime csChannels %= modifyChannelById cId (addChannelTypingUser uId ts) + +-- | Handle the websocket event for when a user is updated, e.g. has changed +-- their nickname +handleUserUpdated :: User -> MH () +handleUserUpdated user = do + csUsers %= modifyUserById (userId user) + (\ui -> userInfoFromUser user (ui ^. uiInTeam)) + -- | Given a user fetching strategy, locate the user in the state or -- fetch it from the server, and pass the result to the specified diff --git a/src/Matterhorn/Themes.hs b/src/Matterhorn/Themes.hs --- a/src/Matterhorn/Themes.hs +++ b/src/Matterhorn/Themes.hs @@ -47,6 +47,7 @@ , urlListSelectedAttr , messageSelectAttr , messageSelectStatusAttr + , urlSelectStatusAttr , misspellingAttr , editedMarkingAttr , editedRecentlyMarkingAttr @@ -216,6 +217,9 @@ messageSelectStatusAttr :: AttrName messageSelectStatusAttr = "messageSelectStatus" +urlSelectStatusAttr :: AttrName +urlSelectStatusAttr = "urlSelectStatus" + buttonAttr :: AttrName buttonAttr = "button" @@ -308,6 +312,7 @@ , (urlListSelectedAttr, black `on` yellow) , (messageSelectAttr, black `on` yellow) , (messageSelectStatusAttr, fg black) + , (urlSelectStatusAttr, fg black) , (misspellingAttr, fg red `withStyle` underline) , (editedMarkingAttr, fg yellow) , (editedRecentlyMarkingAttr, black `on` yellow) @@ -369,6 +374,7 @@ , (urlListSelectedAttr, black `on` yellow) , (messageSelectAttr, black `on` yellow) , (messageSelectStatusAttr, fg white) + , (urlSelectStatusAttr, fg white) , (misspellingAttr, fg red `withStyle` underline) , (editedMarkingAttr, fg yellow) , (editedRecentlyMarkingAttr, black `on` yellow) @@ -658,6 +664,9 @@ ) , ( messageSelectStatusAttr , "Message selection: the message selection actions" + ) + , ( urlSelectStatusAttr + , "Link selection: the message selection actions" ) , ( misspellingAttr , "A misspelled word in the chat message editor" diff --git a/src/Matterhorn/TimeUtils.hs b/src/Matterhorn/TimeUtils.hs --- a/src/Matterhorn/TimeUtils.hs +++ b/src/Matterhorn/TimeUtils.hs @@ -1,5 +1,6 @@ module Matterhorn.TimeUtils ( lookupLocalTimeZone + , utcTimezone , startOfDay , justAfter, justBefore , asLocalTime @@ -11,12 +12,14 @@ import Prelude () import Matterhorn.Prelude +import qualified Control.Exception as E import qualified Data.Text as T import Data.Time.Clock ( UTCTime(..) ) import Data.Time.Format ( formatTime, defaultTimeLocale ) -import Data.Time.LocalTime ( LocalTime(..), TimeOfDay(..) ) +import Data.Time.LocalTime ( LocalTime(..), TimeOfDay(..), utc ) import Data.Time.LocalTime.TimeZone.Olson ( getTimeZoneSeriesFromOlsonFile ) -import Data.Time.LocalTime.TimeZone.Series ( localTimeToUTC' +import Data.Time.LocalTime.TimeZone.Series ( TimeZoneSeries(..) + , localTimeToUTC' , utcToLocalTime') import Network.Mattermost.Types ( ServerTime(..) ) @@ -24,9 +27,11 @@ -- | Get the timezone series that should be used for converting UTC -- times into local times with appropriate DST adjustments. -lookupLocalTimeZone :: IO TimeZoneSeries -lookupLocalTimeZone = getTimeZoneSeriesFromOlsonFile "/etc/localtime" +lookupLocalTimeZone :: IO (Either E.SomeException TimeZoneSeries) +lookupLocalTimeZone = E.try $ getTimeZoneSeriesFromOlsonFile "/etc/localtime" +utcTimezone :: TimeZoneSeries +utcTimezone = TimeZoneSeries utc [] -- | Sometimes it is convenient to render a divider between messages; -- the 'justAfter' function can be used to get a time that is after diff --git a/src/Matterhorn/Types.hs b/src/Matterhorn/Types.hs --- a/src/Matterhorn/Types.hs +++ b/src/Matterhorn/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} module Matterhorn.Types ( ConnectionStatus(..) , HelpTopic(..) @@ -19,6 +20,7 @@ , MHError(..) , AttachmentData(..) , CPUUsagePolicy(..) + , SemEq(..) , tabbedWindow , getCurrentTabbedWindowEntry , tabbedWindowNextTab @@ -35,8 +37,8 @@ , ViewMessageWindowTab(..) , clearChannelUnreadStatus , ChannelListEntry(..) + , ChannelListEntryType(..) , ChannelListOrientation(..) - , channelListEntryChannelId , channelListEntryUserId , userIdsFromZipper , entryIsDMEntry @@ -52,6 +54,11 @@ , channelTopicDialogEditor , channelTopicDialogFocus + , newSaveAttachmentDialog + , SaveAttachmentDialogState(..) + , attachmentPathEditor + , attachmentPathDialogFocus + , Config(..) , configUserL , configHostL @@ -69,6 +76,7 @@ , configURLOpenCommandL , configURLOpenCommandInteractiveL , configActivityNotifyCommandL + , configActivityNotifyVersionL , configActivityBellL , configShowMessageTimestampsL , configShowBackgroundL @@ -91,7 +99,9 @@ , configCpuUsagePolicyL , configDefaultAttachmentPathL , configChannelListOrientationL + , configMouseModeL + , NotificationVersion(..) , HelpScreen(..) , PasswordSource(..) , TokenSource(..) @@ -143,6 +153,7 @@ , tsChannelTopicDialog , tsReactionEmojiListOverlay , tsThemeListOverlay + , tsSaveAttachmentDialog , ChatState , newState @@ -154,10 +165,12 @@ , csTeam , csChannelListOrientation , csResources + , csLastMouseDownEvent , csCurrentChannel , csCurrentChannelId , csCurrentTeamId , csPostMap + , csUsers , csConnectionStatus , csWorkerIsBusy , csChannel @@ -174,6 +187,7 @@ , emptyEditState , cedAttachmentList , cedFileBrowser + , unsafeCedFileBrowser , cedYankBuffer , cedSpellChecker , cedMisspellings @@ -249,8 +263,10 @@ , userPrefDirectChannelPrefs , userPrefTeammateNameDisplayMode , userPrefTeamOrder + , userPrefFavoriteChannelPrefs , dmChannelShowPreference , groupChannelShowPreference + , favoriteChannelPreference , defaultUserPreferences , setUserPreferences @@ -303,8 +319,6 @@ , withChannelOrDefault , userList , resetAutocomplete - , hasUnread - , hasUnread' , isMine , setUserStatus , myUser @@ -354,7 +368,7 @@ import Brick.AttrMap ( AttrMap ) import qualified Brick.BChan as BCH import Brick.Forms (Form) -import Brick.Widgets.Edit ( Editor, editor ) +import Brick.Widgets.Edit ( Editor, editor, applyEdit ) import Brick.Widgets.List ( List, list ) import qualified Brick.Widgets.FileBrowser as FB import Control.Concurrent ( ThreadId ) @@ -371,9 +385,10 @@ import qualified Data.Kind as K import Data.Ord ( comparing ) import qualified Data.HashMap.Strict as HM -import Data.List ( sortBy, nub, elemIndex ) +import Data.List ( sortBy, nub, elemIndex, partition ) import qualified Data.Sequence as Seq import qualified Data.Text as T +import qualified Data.Text.Zipper as Z2 import Data.Time.Clock ( getCurrentTime, addUTCTime ) import Data.UUID ( UUID ) import qualified Data.Vector as Vec @@ -411,6 +426,12 @@ -- * Configuration +-- | A notification version for the external notifier +data NotificationVersion = + NotifyV1 + | NotifyV2 + deriving (Eq, Read, Show) + -- | A user password is either given to us directly, or a command -- which we execute to find the password. data PasswordSource = @@ -429,28 +450,41 @@ data ChannelListGroup = ChannelGroupPublicChannels Int | ChannelGroupPrivateChannels Int + | ChannelGroupFavoriteChannels Int | ChannelGroupDirectMessages Int deriving (Eq) channelListGroupUnread :: ChannelListGroup -> Int channelListGroupUnread (ChannelGroupPublicChannels n) = n channelListGroupUnread (ChannelGroupPrivateChannels n) = n +channelListGroupUnread (ChannelGroupFavoriteChannels n) = n channelListGroupUnread (ChannelGroupDirectMessages n) = n + nonDMChannelListGroupUnread :: ChannelListGroup -> Int nonDMChannelListGroupUnread (ChannelGroupPublicChannels n) = n nonDMChannelListGroupUnread (ChannelGroupPrivateChannels n) = n +nonDMChannelListGroupUnread (ChannelGroupFavoriteChannels n) = n nonDMChannelListGroupUnread (ChannelGroupDirectMessages _) = 0 -- | The type of channel list entries. data ChannelListEntry = - CLChannel ChannelId + ChannelListEntry { channelListEntryChannelId :: ChannelId + , channelListEntryType :: ChannelListEntryType + , channelListEntryUnread :: Bool + , channelListEntrySortValue :: T.Text + , channelListEntryFavorite :: Bool + } + deriving (Eq, Show, Ord) + +data ChannelListEntryType = + CLChannel -- ^ A non-DM entry - | CLUserDM ChannelId UserId + | CLUserDM UserId -- ^ A single-user DM entry - | CLGroupDM ChannelId + | CLGroupDM -- ^ A multi-user DM entry - deriving (Eq, Show) + 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 @@ -489,6 +523,8 @@ -- whether it should be given control of the terminal). , configActivityNotifyCommand :: Maybe T.Text -- ^ The command to run for activity notifications. + , configActivityNotifyVersion :: NotificationVersion + -- ^ The activity notifier version. , configActivityBell :: Bool -- ^ Whether to ring the terminal bell on activity. , configShowMessageTimestamps :: Bool @@ -538,6 +574,8 @@ -- ^ The default path for browsing attachments , configChannelListOrientation :: ChannelListOrientation -- ^ The orientation of the channel list. + , configMouseMode :: Bool + -- ^ Whether to enable mouse support in matterhorn } deriving (Eq, Show) -- | The policy for CPU usage. @@ -570,14 +608,11 @@ , _userPrefFlaggedPostList :: Seq FlaggedPost , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool , _userPrefDirectChannelPrefs :: HashMap UserId Bool + , _userPrefFavoriteChannelPrefs :: HashMap ChannelId Bool , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode , _userPrefTeamOrder :: Maybe [TeamId] } -hasUnread :: ChatState -> ChannelId -> Bool -hasUnread st cId = fromMaybe False $ - hasUnread' <$> findChannelById cId (_csChannels st) - hasUnread' :: ClientChannel -> Bool hasUnread' chan = fromMaybe False $ do let info = _ccInfo chan @@ -596,47 +631,67 @@ -> Users -> [(ChannelListGroup, [ChannelListEntry])] mkChannelZipperList now config tId cconfig prefs cs us = - [ let (unread, entries) = getChannelEntriesInOrder tId cs Ordinary - in (ChannelGroupPublicChannels unread, entries) - , let (unread, entries) = getChannelEntriesInOrder tId cs Private - in (ChannelGroupPrivateChannels unread, entries) - , let (unread, entries) = getDMChannelEntriesInOrder now config cconfig prefs us cs - in (ChannelGroupDirectMessages unread, entries) - ] + 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 + in [ let unread = length $ filter channelListEntryUnread favEntries + in (ChannelGroupFavoriteChannels unread, sortChannelListEntries favEntries) + , let unread = length $ filter channelListEntryUnread normEntries + in (ChannelGroupPublicChannels unread, sortChannelListEntries normEntries) + , let unread = length $ filter channelListEntryUnread privEntries + in (ChannelGroupPrivateChannels unread, sortChannelListEntries privEntries) + , let unread = length $ filter channelListEntryUnread dmEntries + in (ChannelGroupDirectMessages unread, sortDMChannelListEntries dmEntries) + ] -getChannelEntriesInOrder :: TeamId -> ClientChannels -> Type -> (Int, [ChannelListEntry]) -getChannelEntriesInOrder tId cs ty = +sortChannelListEntries :: [ChannelListEntry] -> [ChannelListEntry] +sortChannelListEntries = sortBy (comparing channelListEntrySortValue) + +sortDMChannelListEntries :: [ChannelListEntry] -> [ChannelListEntry] +sortDMChannelListEntries = sortBy compareDMChannelListEntries + +partitionFavorites :: [ChannelListEntry] -> ([ChannelListEntry], [ChannelListEntry]) +partitionFavorites = partition channelListEntryFavorite + +getChannelEntriesByType :: TeamId -> UserPreferences -> ClientChannels -> Type -> [ChannelListEntry] +getChannelEntriesByType tId prefs cs ty = let matches (_, info) = info^.ccInfo.cdType == ty && info^.ccInfo.cdTeamId == Just tId pairs = filteredChannels matches cs - unread = length $ filter (== True) $ (hasUnread' . snd) <$> pairs - entries = fmap (CLChannel . fst) $ - sortBy (comparing ((^.ccInfo.cdDisplayName.to T.toLower) . snd)) pairs - in (unread, entries) + entries = mkEntry <$> pairs + mkEntry (cId, ch) = ChannelListEntry { channelListEntryChannelId = cId + , channelListEntryType = CLChannel + , channelListEntryUnread = hasUnread' ch + , channelListEntrySortValue = ch^.ccInfo.cdDisplayName.to T.toLower + , channelListEntryFavorite = isFavorite prefs cId + } + in entries -getDMChannelEntriesInOrder :: UTCTime - -> Config - -> Maybe ClientConfig - -> UserPreferences - -> Users - -> ClientChannels - -> (Int, [ChannelListEntry]) -getDMChannelEntriesInOrder now config cconfig prefs us cs = - let oneOnOneDmChans = getDMChannelEntries now config cconfig prefs us cs +getDMChannelEntries :: UTCTime + -> Config + -> Maybe ClientConfig + -> UserPreferences + -> Users + -> ClientChannels + -> [ChannelListEntry] +getDMChannelEntries now config cconfig prefs us cs = + let oneOnOneDmChans = getSingleDMChannelEntries now config cconfig prefs us cs groupChans = getGroupDMChannelEntries now config prefs cs - allDmChans = groupChans <> oneOnOneDmChans - sorter (u1, n1, _) (u2, n2, _) = - if u1 == u2 - then compare n1 n2 - else if u1 && not u2 - then LT - else GT - sorted = sortBy sorter allDmChans - third (_, _, c) = c - fst3 (a, _, _) = a - unread = length $ filter id $ fst3 <$> sorted - in (unread, third <$> sorted) + in groupChans <> oneOnOneDmChans +compareDMChannelListEntries :: ChannelListEntry -> ChannelListEntry -> Ordering +compareDMChannelListEntries e1 e2 = + let u1 = channelListEntryUnread e1 + u2 = channelListEntryUnread e2 + n1 = channelListEntrySortValue e1 + n2 = channelListEntrySortValue e2 + in if u1 == u2 + then compare n1 n2 + else if u1 && not u2 + then LT + else GT + useNickname' :: Maybe ClientConfig -> UserPreferences -> Bool useNickname' clientConfig prefs = let serverSetting = case clientConfig^?_Just.to clientConfigTeammateNameDisplay of @@ -657,22 +712,27 @@ -> Config -> UserPreferences -> ClientChannels - -> [(Bool, T.Text, ChannelListEntry)] + -> [ChannelListEntry] getGroupDMChannelEntries now config prefs cs = let matches (_, info) = info^.ccInfo.cdType == Group && info^.ccInfo.cdTeamId == Nothing && groupChannelShouldAppear now config prefs info - in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdDisplayName, CLGroupDM cId)) $ + in fmap (\(cId, ch) -> ChannelListEntry { channelListEntryChannelId = cId + , channelListEntryType = CLGroupDM + , channelListEntryUnread = hasUnread' ch + , channelListEntrySortValue = ch^.ccInfo.cdDisplayName + , channelListEntryFavorite = isFavorite prefs cId + }) $ filteredChannels matches cs -getDMChannelEntries :: UTCTime - -> Config - -> Maybe ClientConfig - -> UserPreferences - -> Users - -> ClientChannels - -> [(Bool, T.Text, ChannelListEntry)] -getDMChannelEntries now config cconfig prefs us cs = +getSingleDMChannelEntries :: UTCTime + -> Config + -> Maybe ClientConfig + -> UserPreferences + -> Users + -> ClientChannels + -> [ChannelListEntry] +getSingleDMChannelEntries now config cconfig prefs us cs = let mapping = allDmChannelMappings cs mappingWithUserInfo = catMaybes $ getInfo <$> mapping getInfo (uId, cId) = do @@ -682,11 +742,22 @@ True -> Nothing False -> if dmChannelShouldAppear now config prefs c - then return (hasUnread' c, displayNameForUser u cconfig prefs, CLUserDM cId uId) + then return (ChannelListEntry { channelListEntryChannelId = cId + , channelListEntryType = CLUserDM uId + , channelListEntryUnread = hasUnread' c + , channelListEntrySortValue = displayNameForUser u cconfig prefs + , channelListEntryFavorite = isFavorite prefs cId + }) else Nothing in mappingWithUserInfo --- Always show a DM channel if it has unread activity. +-- | Return whether the specified channel has been marked as a favorite +-- channel. +isFavorite :: UserPreferences -> ChannelId -> Bool +isFavorite prefs cId = favoriteChannelPreference prefs cId == Just True + +-- Always show a DM channel if it has unread activity or has been marked +-- as a favorite. -- -- If it has no unread activity and if the preferences explicitly say to -- hide it, hide it. @@ -700,29 +771,43 @@ cutoff = ServerTime localCutoff updated = c^.ccInfo.cdUpdated Just uId = c^.ccInfo.cdDMUserId - in if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) + cId = c^.ccInfo.cdChannelId + in if isFavorite prefs cId then True - else case dmChannelShowPreference prefs uId of - Just False -> False - _ -> or [ - -- The channel was updated recently enough - updated >= cutoff - ] + else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) + then True + else case dmChannelShowPreference prefs uId of + Just False -> False + _ -> or [ + -- The channel was updated recently enough + updated >= cutoff + ]) +-- Always show a group DM channel if it has unread activity or has been +-- marked as a favorite. +-- +-- If it has no unread activity and if the preferences explicitly say to +-- hide it, hide it. +-- +-- Otherwise, only show it if at least one of the other conditions are +-- met (see 'or' below). groupChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool groupChannelShouldAppear now config prefs c = let ndays = configDirectChannelExpirationDays config localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now cutoff = ServerTime localCutoff updated = c^.ccInfo.cdUpdated - in if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) + cId = c^.ccInfo.cdChannelId + in if isFavorite prefs cId then True - else case groupChannelShowPreference prefs (c^.ccInfo.cdChannelId) of - Just False -> False - _ -> or [ - -- The channel was updated recently enough - updated >= cutoff - ] + else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) + then True + else case groupChannelShowPreference prefs cId of + Just False -> False + _ -> or [ + -- The channel was updated recently enough + updated >= cutoff + ]) dmChannelShowPreference :: UserPreferences -> UserId -> Maybe Bool dmChannelShowPreference ps uId = HM.lookup uId (_userPrefDirectChannelPrefs ps) @@ -730,6 +815,9 @@ groupChannelShowPreference :: UserPreferences -> ChannelId -> Maybe Bool groupChannelShowPreference ps cId = HM.lookup cId (_userPrefGroupChannelPrefs ps) +favoriteChannelPreference :: UserPreferences -> ChannelId -> Maybe Bool +favoriteChannelPreference ps cId = HM.lookup cId (_userPrefFavoriteChannelPrefs ps) + -- * Internal Names and References -- | This 'Name' type is the type used in 'brick' to identify various @@ -745,6 +833,7 @@ | SyntaxHighlightHelpText | KeybindingHelpText | ChannelSelectString TeamId + | ChannelSelectEntry ChannelSelectMatch | CompletionAlternatives TeamId | CompletionList TeamId | JoinChannelList TeamId @@ -773,9 +862,41 @@ | ChannelTopicSaveButton TeamId | ChannelTopicCancelButton TeamId | ChannelTopicEditorPreview TeamId + | ChannelTopic | TeamList + | ClickableChannelListEntry ChannelId + | ClickableTeamListEntry TeamId + | ClickableURL Name Int LinkTarget + | ClickableURLInMessage MessageId Int LinkTarget + | ClickableUsernameInMessage MessageId Int Text + | ClickableUsername Name Int Text + | ClickableURLListEntry Int LinkTarget + | ClickableReactionInMessage PostId Text (Set UserId) + | ClickableReaction PostId Text (Set UserId) + | AttachmentPathEditor TeamId + | AttachmentPathSaveButton TeamId + | AttachmentPathCancelButton TeamId + | RenderedMessage MessageId + | ReactionEmojiListOverlayEntry (Bool, T.Text) deriving (Eq, Show, Ord) +-- | Types that provide a "semantically equal" operation. Two values may +-- be semantically equal even if they are not equal according to Eq if, +-- for example, they are equal on the basis of some fields that are more +-- pertinent than others. +class (Show a, Eq a, Ord a) => SemEq a where + semeq :: a -> a -> Bool + +instance SemEq Name where + semeq (ClickableURLInMessage mId1 _ t1) (ClickableURLInMessage mId2 _ t2) = mId1 == mId2 && t1 == t2 + semeq (ClickableUsernameInMessage mId1 _ n) (ClickableUsernameInMessage mId2 _ n2) = mId1 == mId2 && n == n2 + semeq a b = a == b + +instance SemEq a => SemEq (Maybe a) where + semeq Nothing Nothing = True + semeq (Just a) (Just b) = a `semeq` b + semeq _ _ = False + -- | The sum type of exceptions we expect to encounter on authentication -- failure. We encode them explicitly here so that we can print them in -- a more user-friendly manner than just 'show'. @@ -833,7 +954,7 @@ -- ^ The original entry data corresponding to the -- text match. } - deriving (Eq, Show) + deriving (Eq, Show, Ord) data ChannelSelectPattern = CSP MatchType Text | CSPAny @@ -864,6 +985,7 @@ , _userPrefFlaggedPostList = mempty , _userPrefGroupChannelPrefs = mempty , _userPrefDirectChannelPrefs = mempty + , _userPrefFavoriteChannelPrefs = mempty , _userPrefTeammateNameDisplayMode = Nothing , _userPrefTeamOrder = Nothing } @@ -889,6 +1011,13 @@ (groupChannelShow gp) (_userPrefGroupChannelPrefs u) } + | Just fp <- preferenceToFavoriteChannelPreference p = + u { _userPrefFavoriteChannelPrefs = + HM.insert + (favoriteChannelId fp) + (favoriteChannelShow fp) + (_userPrefFavoriteChannelPrefs u) + } | Just tIds <- preferenceToTeamOrder p = u { _userPrefTeamOrder = Just tIds } @@ -1186,6 +1315,7 @@ | ManageAttachmentsBrowseFiles | EditNotifyPrefs | ChannelTopicWindow + | SaveAttachmentWindow LinkChoice deriving (Eq) -- | We're either connected or we're not. @@ -1374,6 +1504,10 @@ ChatState { _csResources :: ChatResources -- ^ Global application-wide resources that don't change -- much. + , _csLastMouseDownEvent :: Maybe (Brick.BrickEvent Name MHEvent) + -- ^ The most recent mouse click event we got. We reset + -- this on mouse up so we can ignore clicks whenever this + -- is already set. , _csTeams :: HashMap TeamId TeamState -- ^ The state for each team that we are in. , _csTeamZipper :: Z.Zipper () TeamId @@ -1442,7 +1576,7 @@ , _tsChannelSelectState :: ChannelSelectState -- ^ The state of the user's input and selection for -- channel selection mode. - , _tsUrlList :: List Name LinkChoice + , _tsUrlList :: List Name (Int, LinkChoice) -- ^ The URL list used to show URLs drawn from messages in -- a channel. , _tsViewedMessage :: Maybe (Message, TabbedWindow ViewMessageWindowTab) @@ -1477,6 +1611,9 @@ -- ^ The state of the reaction emoji list overlay. , _tsThemeListOverlay :: ListOverlayState InternalTheme () -- ^ The state of the theme list overlay. + , _tsSaveAttachmentDialog :: SaveAttachmentDialogState + -- ^ The state for the interactive attachment-saving + -- editor window. } -- | Handles for the View Message window's tabs. @@ -1510,6 +1647,14 @@ -- ^ The window focus state (editor/buttons) } +-- | The state of the attachment path window. +data SaveAttachmentDialogState = + SaveAttachmentDialogState { _attachmentPathEditor :: Editor T.Text Name + -- ^ The attachment path editor state. + , _attachmentPathDialogFocus :: FocusRing Name + -- ^ The window focus state (editor/buttons) + } + sortTeams :: [Team] -> [Team] sortTeams = sortBy (compare `on` (T.strip . sanitizeUserText . teamName)) @@ -1548,6 +1693,7 @@ , _tsViewedMessage = Nothing , _tsThemeListOverlay = nullThemeListOverlayState tId , _tsReactionEmojiListOverlay = nullEmojiListOverlayState tId + , _tsSaveAttachmentDialog = newSaveAttachmentDialog tId "" } -- | Make a new channel topic editor window state. @@ -1560,6 +1706,17 @@ ] } +-- | Make a new attachment-saving editor window state. +newSaveAttachmentDialog :: TeamId -> T.Text -> SaveAttachmentDialogState +newSaveAttachmentDialog tId t = + SaveAttachmentDialogState { _attachmentPathEditor = applyEdit Z2.gotoEOL $ + editor (AttachmentPathEditor tId) (Just 1) t + , _attachmentPathDialogFocus = focusRing [ AttachmentPathEditor tId + , AttachmentPathSaveButton tId + , AttachmentPathCancelButton tId + ] + } + nullChannelListOverlayState :: TeamId -> ListOverlayState Channel ChannelSearchScope nullChannelListOverlayState tId = let newList rs = list (JoinChannelList tId) rs 2 @@ -1917,6 +2074,10 @@ -- ^ The specified script was not found | NoSuchHelpTopic T.Text -- ^ The specified help topic was not found + | AttachmentException SomeException + -- ^ IO operations for attaching a file threw an exception + | BadAttachmentPath T.Text + -- ^ The specified file is either a directory or doesn't exist | AsyncErrEvent SomeException -- ^ For errors that arise in the course of async IO operations deriving (Show) @@ -1934,6 +2095,7 @@ makeLenses ''UserPreferences makeLenses ''ConnectionInfo makeLenses ''ChannelTopicDialogState +makeLenses ''SaveAttachmentDialogState Brick.suffixLenses ''Config applyTeamOrderPref :: Maybe [TeamId] -> ChatState -> ChatState @@ -1962,6 +2124,7 @@ let config = _crConfiguration startupStateResources in applyTeamOrderPref (_userPrefTeamOrder $ _crUserPreferences startupStateResources) $ ChatState { _csResources = startupStateResources + , _csLastMouseDownEvent = Nothing , _csTeamZipper = Z.findRight (== startupStateInitialTeam) $ mkTeamZipper startupStateTeams , _csTeams = startupStateTeams @@ -1988,6 +2151,11 @@ tName = teamName $ st^.csTeam(tId).tsTeam in TeamBaseURL (TeamURLName $ sanitizeUserText tName) baseUrl +unsafeCedFileBrowser :: Lens' ChatEditState (FB.FileBrowser Name) +unsafeCedFileBrowser = + lens (\st -> st^.cedFileBrowser ^?! _Just) + (\st t -> st & cedFileBrowser .~ Just t) + getSession :: MH Session getSession = use (csResources.crSession) @@ -2032,23 +2200,22 @@ lens (\ st -> st ^. csTeams . at tId ^?! _Just) (\ st t -> st & csTeams . at tId .~ Just t) -channelListEntryChannelId :: ChannelListEntry -> ChannelId -channelListEntryChannelId (CLChannel cId) = cId -channelListEntryChannelId (CLUserDM cId _) = cId -channelListEntryChannelId (CLGroupDM cId) = cId - channelListEntryUserId :: ChannelListEntry -> Maybe UserId -channelListEntryUserId (CLUserDM _ uId) = Just uId -channelListEntryUserId _ = Nothing +channelListEntryUserId e = + case channelListEntryType e of + CLUserDM uId -> Just uId + _ -> Nothing userIdsFromZipper :: Z.Zipper ChannelListGroup ChannelListEntry -> [UserId] userIdsFromZipper z = concat $ (catMaybes . fmap channelListEntryUserId . snd) <$> Z.toList z entryIsDMEntry :: ChannelListEntry -> Bool -entryIsDMEntry (CLUserDM {}) = True -entryIsDMEntry (CLGroupDM {}) = True -entryIsDMEntry (CLChannel {}) = False +entryIsDMEntry e = + case channelListEntryType e of + CLUserDM {} -> True + CLGroupDM {} -> True + CLChannel {} -> False csCurrentChannel :: Lens' ChatState ClientChannel csCurrentChannel = 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 @@ -75,6 +75,8 @@ | SelectNextTabEvent | SelectPreviousTabEvent + | SaveAttachmentEvent + -- generic cancel | CancelEvent @@ -123,6 +125,20 @@ | AttachmentListDeleteEvent | AttachmentOpenEvent + -- Attachment file browser + | FileBrowserBeginSearchEvent + | FileBrowserSelectEnterEvent + | FileBrowserSelectCurrentEvent + | FileBrowserListPageUpEvent + | FileBrowserListPageDownEvent + | FileBrowserListHalfPageUpEvent + | FileBrowserListHalfPageDownEvent + | FileBrowserListTopEvent + | FileBrowserListBottomEvent + | FileBrowserListNextEvent + | FileBrowserListPrevEvent + + -- Form submission | FormSubmitEvent @@ -147,6 +163,8 @@ , SelectNextTabEvent , SelectPreviousTabEvent + , SaveAttachmentEvent + , EnterFastSelectModeEvent , NextChannelEvent , PrevChannelEvent @@ -222,6 +240,19 @@ , AttachmentListAddEvent , AttachmentListDeleteEvent , AttachmentOpenEvent + + , FileBrowserBeginSearchEvent + , FileBrowserSelectEnterEvent + , FileBrowserSelectCurrentEvent + , FileBrowserListPageUpEvent + , FileBrowserListPageDownEvent + , FileBrowserListHalfPageUpEvent + , FileBrowserListHalfPageDownEvent + , FileBrowserListTopEvent + , FileBrowserListBottomEvent + , FileBrowserListNextEvent + , FileBrowserListPrevEvent + , FormSubmitEvent ] @@ -382,6 +413,8 @@ SelectNextTabEvent -> "select-next-tab" SelectPreviousTabEvent -> "select-previous-tab" + SaveAttachmentEvent -> "save-attachment" + ShowAttachmentListEvent -> "show-attachment-list" EditorKillToBolEvent -> "editor-kill-to-beginning-of-line" @@ -449,5 +482,17 @@ AttachmentListAddEvent -> "add-to-attachment-list" AttachmentListDeleteEvent -> "delete-from-attachment-list" AttachmentOpenEvent -> "open-attachment" + + FileBrowserBeginSearchEvent -> "filebrowser-begin-search" + FileBrowserSelectEnterEvent -> "filebrowser-select-file-or-enter-directory" + FileBrowserSelectCurrentEvent -> "filebrowser-select-current" + FileBrowserListPageUpEvent -> "filebrowser-list-page-up" + FileBrowserListPageDownEvent -> "filebrowser-list-page-down" + FileBrowserListHalfPageUpEvent -> "filebrowser-list-half-page-up" + FileBrowserListHalfPageDownEvent -> "filebrowser-list-half-page-down" + FileBrowserListTopEvent -> "filebrowser-list-top" + FileBrowserListBottomEvent -> "filebrowser-list-bottom" + FileBrowserListNextEvent -> "filebrowser-list-next" + FileBrowserListPrevEvent -> "filebrowser-list-previous" FormSubmitEvent -> "submit-form" diff --git a/src/Matterhorn/Types/Messages.hs b/src/Matterhorn/Types/Messages.hs --- a/src/Matterhorn/Types/Messages.hs +++ b/src/Matterhorn/Types/Messages.hs @@ -144,7 +144,7 @@ data MessageId = MessagePostId PostId | MessageUUID UUID - deriving (Eq, Read, Show, Generic, Hashable) + deriving (Eq, Read, Ord, Show, Generic, Hashable) messageIdPostId :: MessageId -> Maybe PostId messageIdPostId (MessagePostId p) = Just p 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 @@ -23,6 +23,7 @@ , C.ListSpacing(..) , C.EnumeratorType(..) , C.DelimiterType(..) + , C.ColAlignment(..) , TeamBaseURL(..) , TeamURLName(..) @@ -96,6 +97,8 @@ -- ^ A fragment of raw HTML. | HRule -- ^ A horizontal rule. + | Table [C.ColAlignment] [Inlines] [[Inlines]] + -- ^ A table. deriving (Show) -- | Returns whether two blocks have the same type. @@ -237,6 +240,9 @@ instance C.HasStrikethrough Inlines where strikethrough = singleI . EStrikethrough +instance C.HasPipeTable Inlines Blocks where + pipeTable a h b = singleB $ Table a h b + -- Syntax extension for parsing ~channel references. channelSpec :: (Monad m) => C.SyntaxSpec m Inlines Blocks channelSpec = @@ -343,6 +349,7 @@ markdownExtensions = [ C.autolinkSpec , C.strikethroughSpec + , C.pipeTableSpec , usernameSpec , channelSpec , emojiSpec @@ -379,6 +386,8 @@ -- | Locate post hyperlinks in the block and rewrite them as post -- permalinks. rewriteBlockPermalinks :: TeamBaseURL -> Block -> Block +rewriteBlockPermalinks u (Table a h b) = Table a (rewriteInlinePermalinks u <$> h) + (fmap (fmap (rewriteInlinePermalinks u)) b) rewriteBlockPermalinks u (Para s) = Para $ rewriteInlinePermalinks u s rewriteBlockPermalinks u (Header i s) = Header i $ rewriteInlinePermalinks u s rewriteBlockPermalinks u (Blockquote bs) = Blockquote $ rewriteBlocksPermalinks u bs diff --git a/src/Matterhorn/Util.hs b/src/Matterhorn/Util.hs --- a/src/Matterhorn/Util.hs +++ b/src/Matterhorn/Util.hs @@ -8,7 +8,6 @@ import qualified Data.Set as Set - -- | The 'nubOn' function removes duplicate elements from a list. In -- particular, it keeps only the /last/ occurrence of each -- element. The equality of two elements in a call to @nub f@ is 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 @@ -21,12 +21,13 @@ import qualified Graphics.Vty as Vty import Lens.Micro.Platform ( to ) -import Network.Mattermost.Types ( TeamId ) +import Network.Mattermost.Types ( TeamId, Post (postId) ) import Matterhorn.Constants import Matterhorn.Events.Keybindings import Matterhorn.Themes import Matterhorn.Types +import Matterhorn.Types.RichText ( Inline(EUser) ) import Matterhorn.Draw.RichText import Matterhorn.Draw.Messages ( renderMessage, MessageData(..), nameForUserRef ) @@ -110,19 +111,34 @@ mkEntry (reactionName, userIdSet) = let count = str $ "(" <> show (S.size userIdSet) <> ")" name = withDefAttr emojiAttr $ txt $ ":" <> reactionName <> ":" + clickableName = makeClickableName name reactionName userIdSet usernameList = usernameText userIdSet - in (name <+> (padLeft (Pad 1) count)) <=> + in (clickableName <+> (padLeft (Pad 1) count)) <=> (padLeft (Pad 2) usernameList) hs = getHighlightSet st + clickableUsernames i (EUser un) = + Just $ ClickableUsername (ViewMessageReactionsArea tId) i un + clickableUsernames _ _ = + Nothing + usernameText uids = - renderText' Nothing (myUsername st) hs $ + renderText' Nothing (myUsername st) hs (Just clickableUsernames) $ T.intercalate ", " $ fmap (userSigil <>) $ catMaybes (lookupUsername <$> F.toList uids) lookupUsername uid = usernameForUserId uid st + + makeName e us = do + pid <- postId <$> m^.mOriginalPost + Just $ ClickableReaction pid e us + + makeClickableName w e us = + case makeName e us of + Just n -> clickable n w + Nothing -> w viewMessageBox :: ChatState -> Message -> Widget Name viewMessageBox st msg = diff --git a/src/Matterhorn/Zipper.hs b/src/Matterhorn/Zipper.hs --- a/src/Matterhorn/Zipper.hs +++ b/src/Matterhorn/Zipper.hs @@ -10,17 +10,18 @@ , rightL , findRight , maybeFindRight - , updateList , updateListBy , filterZipper , maybeMapZipper , isEmpty + , position ) where import Prelude () import Matterhorn.Prelude hiding (toList) +import Data.List ( elemIndex ) import Data.Maybe ( fromJust ) import qualified Data.Foldable as F import qualified Data.Sequence as Seq @@ -49,6 +50,11 @@ isEmpty :: Zipper a b -> Bool isEmpty = C.isEmpty . zRing +position :: (Eq b) => Zipper a b -> Maybe Int +position z = do + f <- focus z + elemIndex f $ concat $ fmap snd $ toList z + -- Move the focus one element to the left left :: Zipper a b -> Zipper a b left z = z { zRing = C.rotL (zRing z) } @@ -99,10 +105,20 @@ newRing <- C.findRotateTo f (zRing z) return z { zRing = newRing } -updateList :: (Eq b) => [(a, [b])] -> Zipper a b -> Zipper a b -updateList newList oldZip = updateListBy (\old b -> old == Just b) newList oldZip - -updateListBy :: (Eq b) => (Maybe b -> b -> Bool) -> [(a, [b])] -> Zipper a b -> Zipper a b +-- | Update the zipper's entry list, using the specified function +-- determine which entry should be selected in the new zipper state. +updateListBy :: (Eq b) + => (Maybe b -> b -> Bool) + -- ^ The comparison function. This is given the previous + -- zipper's focus value (which is optional) and is given + -- every element in the new zipper state for comparison. + -- This should return True for the item in the new zipper + -- that matches the focused item in the old zipper. + -> [(a, [b])] + -- ^ The new zipper list contents. + -> Zipper a b + -- ^ The old zipper. + -> Zipper a b updateListBy f newList oldZip = findRight (f (focus oldZip)) $ fromList newList maybeMapZipper :: (Eq c) => (b -> Maybe c) -> Zipper a b -> Zipper a c