diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,29 @@ +50200.19.0 +========== + +Improvements: +* Matterhorn's network performance is now greatly improved due to a more + efficient use of the server API. Matterhorn now makes significantly + fewer API requests at startup and whenever the channel is changed. + ([#804](https://github.com/matterhorn-chat/matterhorn/issues/804)) +* Autocompletion now has a less surprising default behavior by + preferring a match that has the input as its prefix. +* The message selection mode (reachable with `C-s` by default) now has + a new keybinding (event `open-message-in-editor`, default binding `O`) + that opens the selected message in `$EDITOR` (or `vi` if `$EDITOR` is + not set). +* Unless specified in the configuration, Matterhorn now + also searches XDG data directories for syntax files. + ([#584](https://github.com/matterhorn-chat/matterhorn/issues/584)) + +Bug fixes: +* `ClearUnreadEvent` (`M-l`) now also refreshes the sidebar + ([#801](https://github.com/matterhorn-chat/matterhorn/issues/801)) +* Reactions with no users no longer linger in + the reactions tab of the message view window. + ([#802](https://github.com/matterhorn-chat/matterhorn/issues/802)) + 50200.18.0 ========== diff --git a/docs/keybindings.md b/docs/keybindings.md --- a/docs/keybindings.md +++ b/docs/keybindings.md @@ -110,6 +110,7 @@ | `Enter` | `fetch-for-gap` | Fetch messages for the selected gap | | `a` | `react-to-message` | Post a reaction to the selected message | | `l` | `copy-post-link` | Copy a post's link to the clipboard | +| `O` | `open-message-in-editor` | Open the message's source in $EDITOR | # User Listings | Keybinding | Event Name | Description | diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 50200.18.0 +version: 50200.19.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 @@ -170,7 +170,7 @@ ghc-options: -fhide-source-paths build-depends: base >=4.8 && <5 - , mattermost-api == 50200.14.0 + , mattermost-api == 50200.15.0 , base-compat >= 0.9 && < 0.13 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.7 @@ -178,24 +178,24 @@ , data-clist >= 0.1.2 && < 0.2 , semigroups >= 0.18 && < 0.20 , connection >= 0.2 && < 0.4 - , text >= 1.2 && < 2.1 + , text >= 1.2.5.0 && < 2.0 , bytestring >= 0.10 && < 0.12 , stm >= 2.4 && < 2.6 , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.5 - , brick >= 1.6 && < 1.7 + , brick >= 1.8 && < 1.9 , brick-skylighting >= 1.0 && < 1.1 , vty >= 5.38 && < 5.39 , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 - , text-zipper >= 0.12 && < 0.13 + , text-zipper >= 0.13 && < 0.14 , time >= 1.6 && < 2.0 , xdg-basedir >= 0.2 && < 0.3 , filepath >= 1.4 && < 1.5 , directory >= 1.3 && < 1.4 , vector < 0.13 - , strict >= 0.3 && < 0.5 + , strict >= 0.3 && < 0.6 , hashable >= 1.2 && < 1.5 , commonmark >= 0.2.1 && < 0.3 , commonmark-extensions >= 0.2.1.2 && < 0.3 @@ -204,10 +204,10 @@ , temporary >= 1.2 && < 1.4 , gitrev >= 1.3 && < 1.4 , Hclip >= 3.0 && < 3.1 - , mtl >= 2.2 && < 2.3 + , mtl >= 2.2 && < 2.4 , aspell-pipe >= 0.6 && < 0.7 , stm-delay >= 0.1 && < 0.2 - , unix >= 2.7.1.0 && < 2.7.3.0 + , unix >= 2.7.1.0 && < 2.9 , skylighting-core >= 0.12 && < 0.13 , timezone-olson >= 0.2 && < 0.3 , timezone-series >= 0.1.6.1 && < 0.2 @@ -249,7 +249,7 @@ build-depends: base >=4.7 && <5 , Unique >= 0.4 && < 0.5 , checkers >= 0.4 && < 0.6 - , tasty >= 0.11 && < 1.3 + , tasty >= 0.11 && < 1.5 , tasty-hunit >= 0.9 && < 0.12 , tasty-quickcheck >= 0.8 && < 0.12 , bytestring diff --git a/src/Matterhorn/Config.hs b/src/Matterhorn/Config.hs --- a/src/Matterhorn/Config.hs +++ b/src/Matterhorn/Config.hs @@ -49,9 +49,10 @@ defaultSkylightingPaths :: IO [FilePath] defaultSkylightingPaths = do xdg <- xdgSyntaxDir + dataDirs <- xdgDataDirs adjacent <- getBundledSyntaxPath cabalDataFiles <- Paths.getDataFileName syntaxDirName - return [xdg, adjacent, cabalDataFiles] + return $ [xdg, adjacent, cabalDataFiles] <> dataDirs getBundledSyntaxPath :: IO FilePath getBundledSyntaxPath = do @@ -214,6 +215,7 @@ , (FlagMessageEvent , [ bind 'f' ]) , (OpenThreadEvent , [ bind 't' ]) , (PinMessageEvent , [ bind 'p' ]) + , (OpenMessageInExternalEditorEvent , [ bind 'O' ]) , (YankMessageEvent , [ bind 'y' ]) , (YankWholeMessageEvent , [ bind 'Y' ]) , (DeleteMessageEvent , [ bind 'd' ]) diff --git a/src/Matterhorn/Draw/MessageInterface.hs b/src/Matterhorn/Draw/MessageInterface.hs --- a/src/Matterhorn/Draw/MessageInterface.hs +++ b/src/Matterhorn/Draw/MessageInterface.hs @@ -130,86 +130,95 @@ let optionList = if null usableOptions then txt "(no actions available for this message)" else hBox $ intersperse (txt " ") usableOptions - usableOptions = catMaybes $ mkOption <$> options - mkOption (f, k, desc) = if f postMsg - then Just $ withDefAttr messageSelectStatusAttr (txt k) <+> - txt (":" <> desc) - else Nothing - numURLs = Seq.length $ msgURLs postMsg - s = if numURLs == 1 then "" else "s" - hasURLs = numURLs > 0 - openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s - hasVerb = isJust (findVerbatimChunk (postMsg^.mText)) - ev = keyEventBindings st (messageSelectKeybindings tId which) - -- make sure these keybinding pieces are up-to-date! - options = [ ( not . isGap - , ev YankWholeMessageEvent - , "yank-all" - ) - , ( \m -> isFlaggable m && not (m^.mFlagged) - , ev FlagMessageEvent - , "flag" - ) - , ( \m -> isFlaggable m && m^.mFlagged - , ev FlagMessageEvent - , "unflag" - ) - , ( isReplyable - , ev OpenThreadEvent - , "thread" - ) - , ( isPostMessage - , ev CopyPostLinkEvent - , "copy-link" - ) - , ( \m -> isPinnable m && not (m^.mPinned) - , ev PinMessageEvent - , "pin" - ) - , ( \m -> isPinnable m && m^.mPinned - , ev PinMessageEvent - , "unpin" - ) - , ( isReplyable - , ev ReplyMessageEvent - , "reply" - ) - , ( not . isGap - , ev ViewMessageEvent - , "view" - ) - , ( isGap - , ev FillGapEvent - , "load messages" - ) - , ( \m -> isMine st m && isEditable m - , ev EditMessageEvent - , "edit" - ) - , ( \m -> isMine st m && isDeletable m - , ev DeleteMessageEvent - , "delete" - ) - , ( const hasURLs - , ev OpenMessageURLEvent - , openUrlsMsg - ) - , ( const hasVerb - , ev YankMessageEvent - , "yank-code" - ) - , ( isReactable - , ev ReactToMessageEvent - , "react" - ) - ] - + usableOptions = mkOption <$> messageSelectionKeyOptions st tId which postMsg + mkOption (k, desc) = withDefAttr messageSelectStatusAttr (txt k) <+> + txt (":" <> desc) in hBox [ hLimit 1 hBorder , txt "[" , optionList , txt "]" , hBorder ] + +messageSelectionKeyOptions :: ChatState + -> TeamId + -> Lens' ChatState (MessageInterface Name i) + -> Message + -> [(T.Text, T.Text)] +messageSelectionKeyOptions st tId which msg = + let ev = keyEventBindings st (messageSelectKeybindings tId which) + hasVerb = isJust (findVerbatimChunk (msg^.mText)) + hasURLs = numURLs > 0 + numURLs = Seq.length $ msgURLs msg + s = if numURLs == 1 then "" else "s" + openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s + getUsable (usable, key, label) = if usable then Just (key, label) else Nothing + options = [ ( not $ isGap msg + , ev YankWholeMessageEvent + , "yank-all" + ) + , ( isFlaggable msg && not (msg^.mFlagged) + , ev FlagMessageEvent + , "flag" + ) + , ( isFlaggable msg && msg^.mFlagged + , ev FlagMessageEvent + , "unflag" + ) + , ( isReplyable msg + , ev OpenThreadEvent + , "thread" + ) + , ( isPostMessage msg + , ev CopyPostLinkEvent + , "copy-link" + ) + , ( isPinnable msg && not (msg^.mPinned) + , ev PinMessageEvent + , "pin" + ) + , ( isPinnable msg && msg^.mPinned + , ev PinMessageEvent + , "unpin" + ) + , ( isReplyable msg + , ev ReplyMessageEvent + , "reply" + ) + , ( not $ isGap msg + , ev ViewMessageEvent + , "view" + ) + , ( not $ isGap msg + , ev OpenMessageInExternalEditorEvent + , "open" + ) + , ( isGap msg + , ev FillGapEvent + , "load messages" + ) + , ( isMine st msg && isEditable msg + , ev EditMessageEvent + , "edit" + ) + , ( isMine st msg && isDeletable msg + , ev DeleteMessageEvent + , "delete" + ) + , ( hasURLs + , ev OpenMessageURLEvent + , openUrlsMsg + ) + , ( hasVerb + , ev YankMessageEvent + , "yank-code" + ) + , ( isReactable msg + , ev ReactToMessageEvent + , "react" + ) + ] + in catMaybes $ getUsable <$> options renderMessageListing :: ChatState -> Bool diff --git a/src/Matterhorn/Draw/Messages.hs b/src/Matterhorn/Draw/Messages.hs --- a/src/Matterhorn/Draw/Messages.hs +++ b/src/Matterhorn/Draw/Messages.hs @@ -240,7 +240,7 @@ Widget Greedy Greedy $ do ctx <- getContext curMsgResult <- withReaderT relaxHeight $ render $ - forceAttr messageSelectAttr $ + forceAttrAllowStyle messageSelectAttr $ padRight Max $ doMsgRender curMsg curThreadState tag let targetHeight = ctx^.availHeightL @@ -465,7 +465,7 @@ , mdRenderReplyParent = False , mdIndentBlocks = False } - in withParent (addEllipsis $ forceAttr replyParentAttr parentMsg) + in withParent (addEllipsis $ forceAttrAllowStyle replyParentAttr parentMsg) where renderBlocks :: HighlightSet -> Maybe Int -> [Widget Name] -> Seq Block diff --git a/src/Matterhorn/Draw/RichText.hs b/src/Matterhorn/Draw/RichText.hs --- a/src/Matterhorn/Draw/RichText.hs +++ b/src/Matterhorn/Draw/RichText.hs @@ -299,7 +299,7 @@ Just u -> B.withDefAttr urlAttr . B.hyperlink (unURL u) addClickable w = case mName of - Nothing -> id w + Nothing -> w Just nm -> B.clickable nm w widget = case val of @@ -319,12 +319,12 @@ textWithCursor :: Text -> Widget a textWithCursor t - | T.any (== cursorSentinel) t = B.visible $ B.txt $ removeCursor t + | cursorSentinel `T.elem` t = B.visible $ B.txt $ removeCursor t | otherwise = B.txt t wrappedTextWithCursor :: Text -> Widget a wrappedTextWithCursor t - | T.any (== cursorSentinel) t = B.visible $ B.txtWrap $ removeCursor t + | cursorSentinel `T.elem` t = B.visible $ B.txtWrap $ removeCursor t | otherwise = B.txtWrap t removeCursor :: Text -> Text diff --git a/src/Matterhorn/Emoji.hs b/src/Matterhorn/Emoji.hs --- a/src/Matterhorn/Emoji.hs +++ b/src/Matterhorn/Emoji.hs @@ -12,7 +12,8 @@ import Matterhorn.Prelude import qualified Control.Exception as E -import Control.Monad.Except +import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT ) +import Control.Monad.Trans ( MonadTrans(..) ) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as BSL import qualified Data.Foldable as F diff --git a/src/Matterhorn/Events/Main.hs b/src/Matterhorn/Events/Main.hs --- a/src/Matterhorn/Events/Main.hs +++ b/src/Matterhorn/Events/Main.hs @@ -16,6 +16,7 @@ import Matterhorn.Events.ThreadWindow import Matterhorn.State.ChannelSelect import Matterhorn.State.Channels +import Matterhorn.State.ChannelList ( updateSidebar ) import Matterhorn.State.Help import Matterhorn.State.Teams import Matterhorn.State.PostListWindow ( enterFlaggedPostListMode ) @@ -90,6 +91,7 @@ , onEvent ClearUnreadEvent "Clear the current channel's unread / edited indicators" $ do withCurrentChannel tId $ \cId _ -> do clearChannelUnreadStatus cId + updateSidebar $ Just tId , onEvent EnterFlaggedPostsEvent "View currently flagged posts" $ enterFlaggedPostListMode tId diff --git a/src/Matterhorn/Events/MessageSelect.hs b/src/Matterhorn/Events/MessageSelect.hs --- a/src/Matterhorn/Events/MessageSelect.hs +++ b/src/Matterhorn/Events/MessageSelect.hs @@ -118,4 +118,7 @@ , onEvent CopyPostLinkEvent "Copy a post's link to the clipboard" $ copyPostLink tId which + + , onEvent OpenMessageInExternalEditorEvent "Open the message's source in $EDITOR" $ + openSelectedMessageInEditor which ] diff --git a/src/Matterhorn/FilePaths.hs b/src/Matterhorn/FilePaths.hs --- a/src/Matterhorn/FilePaths.hs +++ b/src/Matterhorn/FilePaths.hs @@ -11,6 +11,7 @@ , xdgName , locateConfig , xdgSyntaxDir + , xdgDataDirs , syntaxDirName , userEmojiJsonPath , bundledEmojiJsonPath @@ -38,6 +39,7 @@ import System.Environment.XDG.BaseDir ( getUserConfigFile , getAllConfigFiles , getUserConfigDir + , getAllDataDirs ) import System.FilePath ( (), takeBaseName, takeDirectory, splitPath, joinPath ) @@ -65,6 +67,12 @@ -- The path does not necessarily exist. xdgSyntaxDir :: IO FilePath xdgSyntaxDir = ( syntaxDirName) <$> getUserConfigDir xdgName + +-- | Get the list of syntax paths based on XDG data directory paths. +xdgDataDirs :: IO [FilePath] +xdgDataDirs = do + dirs <- getAllDataDirs xdgName + return $ ( syntaxDirName) <$> dirs -- | Get the XDG path to the user-specific emoji JSON file. The path -- does not necessarily exist. diff --git a/src/Matterhorn/State/Common.hs b/src/Matterhorn/State/Common.hs --- a/src/Matterhorn/State/Common.hs +++ b/src/Matterhorn/State/Common.hs @@ -87,10 +87,12 @@ Nothing -> return Nothing Just tId -> Just <$> getServerBaseUrl tId + hostname <- use (csResources.crConn.cdHostnameL) + -- Build the ordered list of posts. Note that postsOrder lists the -- posts most recent first, but we want most recent last. let postsInOrder = findPost <$> (Seq.reverse $ postsOrder postCollection) - mkClientPost p = toClientPost mBaseUrl p (postId <$> parent p) + mkClientPost p = toClientPost hostname mBaseUrl p (postId <$> parent p) clientPosts = mkClientPost <$> postsInOrder addNext cp (msgs, us) = @@ -125,9 +127,11 @@ Nothing -> return Nothing Just tId -> Just <$> getServerBaseUrl tId + hostname <- use (csResources.crConn.cdHostnameL) + let postMap = HM.fromList [ ( pId - , fst $ clientPostToMessage (toClientPost mBaseUrl x Nothing) + , fst $ clientPostToMessage (toClientPost hostname mBaseUrl x Nothing) ) | (pId, x) <- HM.toList (postCollection^.postsPostsL) ] diff --git a/src/Matterhorn/State/Editing.hs b/src/Matterhorn/State/Editing.hs --- a/src/Matterhorn/State/Editing.hs +++ b/src/Matterhorn/State/Editing.hs @@ -530,13 +530,39 @@ tabComplete :: Traversal' ChatState (EditState Name) -> Direction -> MH () tabComplete which dir = do + searchStr <- use (which.esAutocomplete._Just.acPreviousSearchString) + let transform list = let len = list^.L.listElementsL.to length + prefixMatch alt = + T.toLower searchStr `T.isPrefixOf` (T.toLower $ autocompleteAlternativeText alt) in case dir of Forwards -> - if (L.listSelected list == Just (len - 1)) || - (L.listSelected list == Nothing && len > 0) - then L.listMoveTo 0 list + if L.listSelected list == Just (len - 1) + then L.listMoveTo 0 list + else if L.listSelected list == Nothing && len > 0 + -- If the list has nothing selected, then + -- make the initial selection the best match + -- by prefix rather than always selecting + -- the first entry. If there is no match + -- based on prefix, then select the first + -- entry. + -- + -- Note that we only bother with this + -- behavior in the Forward case because in + -- the Backwards case we don't want the + -- first selection to be based on prefix + -- match since that doesn't make sense. + then let new = L.listFindBy prefixMatch list + in if L.listSelected new == Nothing + -- If, after attempting to select + -- by prefix, nothing matched, then + -- there is still no autocomplete + -- alternative selected, so move to + -- the selection to the first entry + -- in the list. + then L.listMoveBy 1 new + else new else L.listMoveBy 1 list Backwards -> if (L.listSelected list == Just 0) || diff --git a/src/Matterhorn/State/MessageSelect.hs b/src/Matterhorn/State/MessageSelect.hs --- a/src/Matterhorn/State/MessageSelect.hs +++ b/src/Matterhorn/State/MessageSelect.hs @@ -6,6 +6,7 @@ , flagSelectedMessage , pinSelectedMessage , viewSelectedMessage + , openSelectedMessageInEditor , fillSelectedGap , copyPostLink , yankSelectedMessageVerbatim @@ -34,9 +35,14 @@ import Brick ( invalidateCache ) import Brick.Widgets.Edit ( applyEdit ) import Control.Monad ( replicateM_ ) +import qualified Data.Text as T import Data.Text.Zipper ( clearZipper, insertMany ) import Data.Maybe ( fromJust ) import Lens.Micro.Platform +import qualified System.Environment as Sys +import System.IO (hClose, hPutStr) +import qualified System.IO.Temp as Sys +import qualified System.Process as Sys import qualified Network.Mattermost.Endpoints as MM import Network.Mattermost.Types @@ -125,6 +131,12 @@ withSelectedMessage which $ \msg -> when (not (isGap msg)) $ viewMessage tId msg +openSelectedMessageInEditor :: Lens' ChatState (MessageInterface n i) + -> MH () +openSelectedMessageInEditor which = + withSelectedMessage which $ \msg -> + when (not (isGap msg)) $ openMessageInEditor msg which + -- This will only work for channel message selection, not thread message -- selection, since there will never be gap entries in the thread view. -- But this is generalized enough that it looks like it should work for @@ -154,6 +166,28 @@ csTeam(tId).tsViewedMessage .= Just (m, w) runTabShowHandlerFor (twValue w) w pushMode tId ViewMessage + +openMessageInEditor :: Message -> Lens' ChatState (MessageInterface n i) -> MH () +openMessageInEditor m which = do + -- If EDITOR is in the environment, write the current message to a + -- temp file, invoke EDITOR on it, read the result, remove the temp + -- file, and update the program state. + -- + -- If EDITOR is not present, fall back to 'vi'. + mEnv <- liftIO $ Sys.lookupEnv "EDITOR" + let editorProgram = maybe "vi" id mEnv + + case m^.mOriginalPost of + Nothing -> return () + Just p -> do + mhSuspendAndResume $ \s -> do + Sys.withSystemTempFile "matterhorn_editor.md" $ \tmpFileName tmpFileHandle -> do + hPutStr tmpFileHandle $ T.unpack $ unsafeUserText $ postMessage p + hClose tmpFileHandle + void $ Sys.system (editorProgram <> " " <> tmpFileName) + return s + + exitMessageSelect which yankSelectedMessageVerbatim :: Lens' ChatState (MessageInterface n i) -> MH () diff --git a/src/Matterhorn/State/Messages.hs b/src/Matterhorn/State/Messages.hs --- a/src/Matterhorn/State/Messages.hs +++ b/src/Matterhorn/State/Messages.hs @@ -48,7 +48,6 @@ import Matterhorn.State.Common import Matterhorn.State.ThreadWindow import Matterhorn.State.MessageSelect -import Matterhorn.State.Reactions import Matterhorn.State.Users import Matterhorn.TimeUtils import Matterhorn.Types @@ -177,7 +176,9 @@ Nothing -> return Nothing Just tId -> Just <$> getServerBaseUrl tId - let (msg, mentionedUsers) = clientPostToMessage (toClientPost mBaseUrl new (new^.postRootIdL)) + hostname <- use (csResources.crConn.cdHostnameL) + + let (msg, mentionedUsers) = clientPostToMessage (toClientPost hostname mBaseUrl new (new^.postRootIdL)) isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL) csChannel (new^.postChannelIdL) . ccMessageInterface.miMessages . traversed . filtered isEditedMessage .= msg @@ -193,8 +194,6 @@ csChannel (new^.postChannelIdL) %= adjustEditedThreshold new csPostMap.ix(postId new) .= msg - asyncFetchReactionsForPost (postChannelId new) new - asyncFetchAttachments new deleteMessage :: Post -> MH () deleteMessage new = do @@ -530,6 +529,8 @@ OldPost p -> (p, False) RecentPost p m -> (p, m) + hostname <- use (csResources.crConn.cdHostnameL) + st <- use id case st ^? csChannel(postChannelId new) of Nothing -> do @@ -566,7 +567,7 @@ Nothing -> return Nothing Just tId -> Just <$> getServerBaseUrl tId - let cp = toClientPost mBaseUrl new (new^.postRootIdL) + let cp = toClientPost hostname mBaseUrl new (new^.postRootIdL) fromMe = (cp^.cpUser == (Just $ myUserId st)) && (isNothing $ cp^.cpUserOverride) userPrefs = st^.csResources.crUserPreferences @@ -627,8 +628,6 @@ -- since all DM channels appear in all teams. addPostToOpenThread (mTId <|> mcurTId) new msg' - asyncFetchReactionsForPost cId new - asyncFetchAttachments new postedChanMessage doHandleAddedMessage = do @@ -1053,39 +1052,6 @@ (\c p -> Just $ do csChannel(c).ccInfo.cdFetchPending .= False addObtainedMessages c (-numToRequest) addTrailingGap p >>= postProcessMessageAdd) - -asyncFetchAttachments :: Post -> MH () -asyncFetchAttachments p = do - let cId = p^.postChannelIdL - pId = p^.postIdL - session <- getSession - host <- use (csResources.crConn.cdHostnameL) - F.forM_ (p^.postFileIdsL) $ \fId -> doAsyncWith Normal $ do - info <- MM.mmGetMetadataForFile fId session - let scheme = "https://" - attUrl = scheme <> host <> urlForFile fId - attachment = mkAttachment (fileInfoName info) attUrl fId - addIfMissing a as = - if isNothing $ Seq.elemIndexL a as - then a Seq.<| as - else as - addAttachment m - | m^.mMessageId == Just (MessagePostId pId) = - m & mAttachments %~ (addIfMissing attachment) - | otherwise = - m - return $ Just $ do - csChannelMessages(cId).traversed %= addAttachment - - curTId <- use csCurrentTeamId - withChannel cId $ \chan -> do - let mTId = chan^.ccInfo.cdTeamId <|> curTId - case mTId of - Nothing -> return () - Just tId -> modifyEachThreadMessage tId cId addAttachment - - invalidateChannelRenderingCache cId - invalidateMessageRenderingCacheByPostId pId -- | Given a post ID, switch to that post's channel and select the post -- in message selection mode. diff --git a/src/Matterhorn/State/Reactions.hs b/src/Matterhorn/State/Reactions.hs --- a/src/Matterhorn/State/Reactions.hs +++ b/src/Matterhorn/State/Reactions.hs @@ -80,9 +80,10 @@ invalidateRenderCache where upd m | m^.mMessageId == Just (MessagePostId $ r^.reactionPostIdL) = - m & mReactions %~ (Map.alter delReaction (r^.reactionEmojiNameL)) + m & mReactions %~ (removeEmptySets . Map.alter delReaction (r^.reactionEmojiNameL)) | otherwise = m delReaction mUs = S.delete (r^.reactionUserIdL) <$> mUs + removeEmptySets = Map.filter (not . S.null) invalidateRenderCache = invalidateMessageRenderingCacheByPostId $ r^.reactionPostIdL diff --git a/src/Matterhorn/Types/Core.hs b/src/Matterhorn/Types/Core.hs --- a/src/Matterhorn/Types/Core.hs +++ b/src/Matterhorn/Types/Core.hs @@ -360,6 +360,7 @@ | EditMessageEvent | ReplyMessageEvent | ReactToMessageEvent + | OpenMessageInExternalEditorEvent -- Attachments | AttachmentListAddEvent @@ -462,6 +463,7 @@ , ("activate-list-item", ActivateListItemEvent) , ("open-thread", OpenThreadEvent) , ("flag-message", FlagMessageEvent) + , ("open-message-in-editor", OpenMessageInExternalEditorEvent) , ("pin-message", PinMessageEvent) , ("view-message", ViewMessageEvent) , ("fetch-for-gap", FillGapEvent) diff --git a/src/Matterhorn/Types/EditState.hs b/src/Matterhorn/Types/EditState.hs --- a/src/Matterhorn/Types/EditState.hs +++ b/src/Matterhorn/Types/EditState.hs @@ -43,6 +43,7 @@ , AutocompleteAlternative(..) , autocompleteAlternativeReplacement + , autocompleteAlternativeText ) where @@ -88,6 +89,22 @@ -- ^ Source, name of a slash command, argspec, and description | EmojiCompletion Text -- ^ The text of an emoji completion + +autocompleteAlternativeText :: AutocompleteAlternative -> Text +autocompleteAlternativeText (UserCompletion u _) = + userUsername u +autocompleteAlternativeText (SpecialMention MentionChannel) = + "channel" +autocompleteAlternativeText (SpecialMention MentionAll) = + "all" +autocompleteAlternativeText (ChannelCompletion _ c) = + unsafeUserText $ channelName c +autocompleteAlternativeText (SyntaxCompletion n) = + n +autocompleteAlternativeText (CommandCompletion _ t _ _) = + t +autocompleteAlternativeText (EmojiCompletion t) = + t -- | The source of an autocompletion alternative. data CompletionSource = Server | Client diff --git a/src/Matterhorn/Types/Posts.hs b/src/Matterhorn/Types/Posts.hs --- a/src/Matterhorn/Types/Posts.hs +++ b/src/Matterhorn/Types/Posts.hs @@ -48,6 +48,7 @@ import Prelude () import Matterhorn.Prelude +import qualified Data.Foldable as F import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.Text as T @@ -193,10 +194,17 @@ else t unEmote _ t = t +attachmentFromFileInfo :: T.Text -> FileInfo -> Attachment +attachmentFromFileInfo hostname info = + let scheme = "https://" + attUrl = scheme <> hostname <> urlForFile fId + fId = fileInfoId info + in mkAttachment (fileInfoName info) attUrl fId + -- | Convert a Mattermost 'Post' to a 'ClientPost', passing in a -- 'ParentId' if it has a known one. -toClientPost :: Maybe TeamBaseURL -> Post -> Maybe PostId -> ClientPost -toClientPost baseUrl p parentId = +toClientPost :: T.Text -> Maybe TeamBaseURL -> Post -> Maybe PostId -> ClientPost +toClientPost hostname baseUrl p parentId = let src = unEmote (postClientPostType p) $ sanitizeUserText $ postMessage p in ClientPost { _cpText = parseMarkdown baseUrl src <> getAttachmentText p , _cpMarkdownSource = src @@ -207,14 +215,19 @@ , _cpPending = False , _cpDeleted = False , _cpPinned = fromMaybe False $ postPinned p - , _cpAttachments = Seq.empty + , _cpAttachments = attachmentFromFileInfo hostname <$> postMetadataFiles (postMetadata p) , _cpInReplyToPost = parentId , _cpPostId = p^.postIdL , _cpChannelId = p^.postChannelIdL - , _cpReactions = Map.empty + , _cpReactions = mkReactionMap $ postMetadataReactions (postMetadata p) , _cpOriginalPost = p , _cpFromWebhook = fromMaybe False $ p^.postPropsL.postPropsFromWebhookL } + +mkReactionMap :: Seq Reaction -> Map.Map T.Text (S.Set UserId) +mkReactionMap rs = + let inserter r m = Map.insertWith S.union (reactionEmojiName r) (S.singleton $ reactionUserId r) m + in F.foldr inserter mempty rs -- | Right now, instead of treating 'attachment' properties specially, we're -- just going to roll them directly into the message text