matterhorn 50200.12.0 → 50200.13.0

raw patch · 59 files changed

+1636/−416 lines, 59 filesdep ~brickdep ~mattermost-apiPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: brick, mattermost-api

API changes (from Hackage documentation)

Files

• CHANGELOG.md +81/−0
• README.md +1/−0
• docs/commands.md +4/−2
• docs/keybindings.md +12/−0
• docs/notification-scripts.md +13/−2
• matterhorn.cabal +6/−3
• src/Matterhorn/App.hs +3/−0
• src/Matterhorn/Command.hs +9/−2
• src/Matterhorn/Config.hs +14/−0
• src/Matterhorn/Draw.hs +2/−0
• src/Matterhorn/Draw/Autocomplete.hs +1/−1
• src/Matterhorn/Draw/ChannelList.hs +11/−7
• src/Matterhorn/Draw/ChannelTopicWindow.hs +1/−1
• src/Matterhorn/Draw/Main.hs +84/−24
• src/Matterhorn/Draw/Messages.hs +137/−63
• src/Matterhorn/Draw/ReactionEmojiListOverlay.hs +2/−1
• src/Matterhorn/Draw/RichText.hs +75/−28
• src/Matterhorn/Draw/RichText/Flatten.hs +128/−37
• src/Matterhorn/Draw/RichText/Wrap.hs +10/−10
• src/Matterhorn/Draw/SaveAttachmentWindow.hs +45/−0
• src/Matterhorn/Draw/ShowHelp.hs +6/−6
• src/Matterhorn/Draw/TabbedWindow.hs +4/−2
• src/Matterhorn/Draw/URLList.hs +4/−4
• src/Matterhorn/Events.hs +94/−3
• src/Matterhorn/Events/Keybindings.hs +12/−0
• src/Matterhorn/Events/ManageAttachments.hs +38/−33
• src/Matterhorn/Events/MessageSelect.hs +7/−1
• src/Matterhorn/Events/SaveAttachmentWindow.hs +65/−0
• src/Matterhorn/Events/UrlSelect.hs +4/−0
• src/Matterhorn/Events/Websocket.hs +6/−1
• src/Matterhorn/Login.hs +4/−1
• src/Matterhorn/State/Attachments.hs +64/−5
• src/Matterhorn/State/Autocomplete.hs +6/−0
• src/Matterhorn/State/ChannelList.hs +2/−1
• src/Matterhorn/State/ChannelSelect.hs +6/−3
• src/Matterhorn/State/Channels.hs +75/−28
• src/Matterhorn/State/Common.hs +27/−11
• src/Matterhorn/State/Editing.hs +5/−2
• src/Matterhorn/State/Links.hs +1/−1
• src/Matterhorn/State/ListOverlay.hs +12/−6
• src/Matterhorn/State/MessageSelect.hs +6/−0
• src/Matterhorn/State/Messages.hs +51/−2
• src/Matterhorn/State/ReactionEmojiListOverlay.hs +2/−14
• src/Matterhorn/State/Reactions.hs +43/−0
• src/Matterhorn/State/SaveAttachmentWindow.hs +41/−0
• src/Matterhorn/State/Setup.hs +4/−2
• src/Matterhorn/State/Setup/Threads.hs +17/−7
• src/Matterhorn/State/Teams.hs +14/−1
• src/Matterhorn/State/UrlSelect.hs +3/−2
• src/Matterhorn/State/Users.hs +9/−0
• src/Matterhorn/Themes.hs +9/−0
• src/Matterhorn/TimeUtils.hs +9/−4
• src/Matterhorn/Types.hs +252/−85
• src/Matterhorn/Types/KeyEvents.hs +45/−0
• src/Matterhorn/Types/Messages.hs +1/−1
• src/Matterhorn/Types/RichText.hs +9/−0
• src/Matterhorn/Util.hs +0/−1
• src/Matterhorn/Windows/ViewMessage.hs +19/−3
• src/Matterhorn/Zipper.hs +21/−5

@@ -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 ========== 

@@ -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 

@@ -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 <path>` | Attach a given file without browsing | | `/create-channel <channel name>` | Create a new public channel | | `/create-private-channel <channel name>` | Create a new private channel | | `/delete-channel` | Delete the current channel | | `/flags` | Open a window of your flagged posts | | `/focus <~channel>` | Focus on a channel or user | | `/focus` | Select from available channels |-| `/group-msg <@user [@user ...]>` | Create a group chat |+| `/group-create <@user [@user ...]>` | Create a group chat | | `/help` | Show the main help screen | | `/help <topic>` | 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 <channel name>` | Rename the current channel's URL name | | `/right` | Focus on the next channel | | `/search <terms>` | Search for posts with given terms |@@ -45,6 +46,7 @@ | `/theme <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 <topic>` | Set the current channel's topic (header) |

@@ -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 |

@@ -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 "<ESC>"). +* 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

@@ -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

@@ -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

@@ -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 ()

@@ -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))

@@ -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

@@ -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

@@ -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

@@ -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) $

@@ -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 ->

@@ -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.

@@ -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 <> ":"

@@ -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 = '‸'

@@ -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 "<"

@@ -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

@@ -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

@@ -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:"

@@ -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 $

@@ -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

@@ -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

@@ -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) ]

@@ -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

@@ -1,4 +1,10 @@-module Matterhorn.Events.MessageSelect where+module Matterhorn.Events.MessageSelect+  ( messageSelectKeybindings+  , messageSelectKeyHandlers+  , onEventMessageSelect+  , onEventMessageSelectDeleteConfirm+  )+where  import           Prelude () import           Matterhorn.Prelude

@@ -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 ()

@@ -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 

@@ -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 ()

@@ -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 =

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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 =

@@ -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

@@ -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)

@@ -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 ()

@@ -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

@@ -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           ]

@@ -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. --

@@ -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"

@@ -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

@@ -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"

@@ -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

@@ -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 =

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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 =

@@ -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