matterhorn 50200.5.0 → 50200.6.0
raw patch · 18 files changed
+121/−72 lines, 18 filesdep ~mattermost-apidep ~mattermost-api-qcdep ~vty
Dependency ranges changed: mattermost-api, mattermost-api-qc, vty
Files
- CHANGELOG.md +16/−0
- README.md +9/−4
- matterhorn.cabal +6/−6
- src/App.hs +2/−2
- src/Command.hs +3/−2
- src/Draw/ManageAttachments.hs +8/−4
- src/Draw/ShowHelp.hs +1/−1
- src/Events/ManageAttachments.hs +34/−16
- src/Scripts.hs +7/−6
- src/State/Async.hs +4/−5
- src/State/Attachments.hs +1/−1
- src/State/Channels.hs +10/−10
- src/State/MessageSelect.hs +1/−1
- src/State/Messages.hs +6/−6
- src/State/Reactions.hs +1/−1
- src/State/Users.hs +1/−1
- src/Types.hs +7/−4
- src/Types/Messages.hs +4/−2
CHANGELOG.md view
@@ -1,4 +1,20 @@ +50200.6.0+=========++Bug fixes:+ * Initialization of the attachment file browser is delayed until it is+ needed.+ * Reply message coalescing now occurs if a non-reply intervening+ message is deleted.+ * When showing the attachment management window, the main UI is dimmed.+ * Fixed a race condition where a script completes after the user+ changes channels.++Other improvements:+ * README: improve mention of display corruption (relevant to #544)+ * README: clarify source build instructions (relevant to #536)+ 50200.5.0 =========
README.md view
@@ -229,10 +229,15 @@ # Building -To build Matterhorn, you'll need an appropriate `ghc`/`cabal`-installation. We currently build on GHC 8.4. We suggest you use a binary-release if possible.+If you just want to run Matterhorn, we strongly suggest running a binary+release (see above). +If you want to contribute changes to Matterhorn, you'll need to build+it from source. To do that you'll need an appropriate `ghc`/`cabal`+installation (see the latest Travis-CI builds for tested versions).+You'll also need a GitHub account, since our Git submodules are set up+to use SSH with GitHub.+ `matterhorn` is built by running the following commands: ```@@ -332,7 +337,7 @@ * https://medium.com/@dubistkomisch/how-to-actually-get-italics-and-true-colour-to-work-in-iterm-tmux-vim-9ebe55ebc2be * https://github.com/tmux/tmux/blob/2.1/FAQ#L355-L383 -## I am seeing malformed characters when I run matterhorn in my terminal. What could be causing this?+## I am seeing malformed characters or display corruption when I run matterhorn in my terminal. What could be causing this? Some terminal emulators cannot handle the extra escaping that occurs when the URL hyperlinking mode is enabled. Try setting `hyperlinkUrls =
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 50200.5.0+version: 50200.6.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@@ -132,7 +132,7 @@ NoImplicitPrelude ghc-options: -Wall -threaded -with-rtsopts=-I0 -Wcompat build-depends: base >=4.8 && <5- , mattermost-api == 50200.2.0+ , mattermost-api == 50200.3.0 , base-compat >= 0.9 && < 0.11 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.7@@ -147,7 +147,7 @@ , microlens-platform >= 0.3 && < 0.4 , brick >= 0.50 && < 0.51 , brick-skylighting >= 0.2 && < 0.4- , vty >= 5.23.1 && < 5.26+ , vty >= 5.26 && < 5.27 , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.10 && < 0.11@@ -206,8 +206,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1- , mattermost-api == 50200.2.0- , mattermost-api-qc == 50200.2.0+ , mattermost-api == 50200.3.0+ , mattermost-api-qc == 50200.3.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7@@ -227,7 +227,7 @@ , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3 , vector < 0.13- , vty >= 5.23.1 && < 5.26+ , vty >= 5.26 && < 5.27 , xdg-basedir >= 0.2 && < 0.3 , semigroups >= 0.18 && < 0.19 , uuid >= 1.3 && < 1.4
src/App.hs view
@@ -17,7 +17,7 @@ import Config import Draw-import Events+import qualified Events import IOUtil import InputHistory import LastRunState@@ -46,7 +46,7 @@ ViewMessage -> Nothing ShowHelp _ -> Nothing UrlSelect -> Nothing- , appHandleEvent = onEvent+ , appHandleEvent = Events.onEvent , appStartEvent = return , appAttrMap = (^.csResources.crTheme) }
src/Command.hs view
@@ -219,8 +219,9 @@ (LineArg (userSigil <> "user [" <> userSigil <> "user ...]")) createGroupChannel , Cmd "sh" "Run a prewritten shell script"- (TokenArg "script" (LineArg "message")) $ \ (script, text) ->- findAndRunScript script text+ (TokenArg "script" (LineArg "message")) $ \ (script, text) -> do+ cId <- use csCurrentChannelId+ findAndRunScript cId script text , Cmd "me" "Send an emote message" (LineArg "message") $
src/Draw/ManageAttachments.hs view
@@ -7,10 +7,11 @@ import Prelude.MH import Brick-import Brick.Widgets.List-import Brick.Widgets.Center import Brick.Widgets.Border+import Brick.Widgets.Center import qualified Brick.Widgets.FileBrowser as FB+import Brick.Widgets.List+import Data.Maybe ( fromJust ) import Types import Types.KeyEvents@@ -21,7 +22,7 @@ drawManageAttachments :: ChatState -> [Widget Name] drawManageAttachments st =- topLayer : drawMain True st+ topLayer : drawMain False st where topLayer = case appMode st of ManageAttachments -> drawAttachmentList st@@ -58,4 +59,7 @@ hLimit 60 $ vLimit 20 $ borderWithLabel (txt "Attach File") $- FB.renderFileBrowser True (st^.csEditState.cedFileBrowser)+ -- invariant: cedFileBrowser is not Nothing if appMode is+ -- ManageAttachmentsBrowseFiles, and that is the only way to reach+ -- this code, ergo the fromJust.+ FB.renderFileBrowser True $ fromJust (st^.csEditState.cedFileBrowser)
src/Draw/ShowHelp.hs view
@@ -222,7 +222,7 @@ prevChanBinding = ppBinding (getFirstDefaultBinding PrevChannelEvent) validKeys = map (padTop (Pad 1) . renderText . mconcat) [ [ "The syntax used for key sequences consists of zero or more "- , "single-character modifier characters followed by a keystroke "+ , "single-character modifier characters followed by a keystroke, " , "all separated by dashes. The available modifier keys are " , "**S** for Shift, **C** for Ctrl, **A** for Alt, and **M** for " , "Meta. So, for example, **"
src/Events/ManageAttachments.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module Events.ManageAttachments ( onEventManageAttachments@@ -17,7 +18,7 @@ import qualified Data.Text as T import qualified Data.Vector as Vector import qualified Graphics.Vty as V-import Lens.Micro.Platform ( (%=), to )+import Lens.Micro.Platform ( (?=), (%=), to ) import Types import Types.KeyEvents@@ -63,6 +64,22 @@ openSelectedBrowserEntry ] +withFileBrowser :: ((FB.FileBrowser Name) -> MH ()) -> MH ()+withFileBrowser f = do+ use (csEditState.cedFileBrowser) >>= \case+ Nothing -> do+ -- The widget has not been created yet. This should+ -- normally not occur, because the ManageAttachments+ -- events should not fire when there is no FileBrowser+ -- Widget active to cause Brick to generate these events.+ -- This could therefore be implemented as an `error "BUG:+ -- ..."` handler, but the more benign approach is to+ -- simply create an available FileBrowser at this stage.+ new_b <- liftIO $ FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser Nothing+ csEditState.cedFileBrowser ?= new_b+ f new_b+ Just b -> f b+ openSelectedAttachment :: MH () openSelectedAttachment = do cur <- use (csEditState.cedAttachmentList.to L.listSelectedElement)@@ -72,26 +89,26 @@ attachmentDataFileInfo entry) openSelectedBrowserEntry :: MH ()-openSelectedBrowserEntry = do- b <- use (csEditState.cedFileBrowser)+openSelectedBrowserEntry = withFileBrowser $ \b -> case FB.fileBrowserCursor b of Nothing -> return () Just entry -> void $ openURL (OpenLocalFile $ FB.fileInfoFilePath entry) onEventBrowseFile :: V.Event -> MH () onEventBrowseFile e = do- b <- use (csEditState.cedFileBrowser)- case FB.fileBrowserIsSearching b of- False ->- handleKeyboardEvent attachmentBrowseKeybindings handleFileBrowserEvent e- True ->- handleFileBrowserEvent e+ withFileBrowser $ \b -> do+ case FB.fileBrowserIsSearching b of+ False ->+ handleKeyboardEvent attachmentBrowseKeybindings handleFileBrowserEvent e+ True ->+ handleFileBrowserEvent e - b' <- use (csEditState.cedFileBrowser)- case FB.fileBrowserException b' of- Nothing -> return ()- Just ex -> do- mhLog LogError $ T.pack $ "FileBrowser exception: " <> show ex+ -- n.b. the FileBrowser may have been updated above, so re-acquire it+ withFileBrowser $ \b -> do+ case FB.fileBrowserException b of+ Nothing -> return ()+ Just ex -> do+ mhLog LogError $ T.pack $ "FileBrowser exception: " <> show ex cancelAttachmentBrowse :: MH () cancelAttachmentBrowse = do@@ -102,9 +119,10 @@ handleFileBrowserEvent :: V.Event -> MH () handleFileBrowserEvent e = do- mhHandleEventLensed (csEditState.cedFileBrowser) FB.handleFileBrowserEvent e- b <- use (csEditState.cedFileBrowser)+ let fbHandle ev = sequence . (fmap (FB.handleFileBrowserEvent ev))+ mhHandleEventLensed (csEditState.cedFileBrowser) fbHandle e + withFileBrowser $ \b -> do -- TODO: Check file browser exception state let entries = FB.fileBrowserSelection b forM_ entries $ \entry -> do
src/Scripts.hs view
@@ -12,19 +12,21 @@ import qualified Data.Text as T import System.Exit ( ExitCode(..) ) +import Network.Mattermost.Types ( ChannelId )+ import FilePaths ( Script(..), getAllScripts, locateScriptPath ) import State.Common import State.Messages ( sendMessage ) import Types -findAndRunScript :: Text -> Text -> MH ()-findAndRunScript scriptName input = do+findAndRunScript :: ChannelId -> Text -> Text -> MH ()+findAndRunScript cId scriptName input = do fpMb <- liftIO $ locateScriptPath (T.unpack scriptName) outputChan <- use (csResources.crSubprocessLog) case fpMb of ScriptPath scriptPath -> do- doAsyncWith Preempt $ runScript outputChan scriptPath input+ doAsyncWith Preempt $ runScript cId outputChan scriptPath input NonexecScriptPath scriptPath -> do let msg = ("The script `" <> T.pack scriptPath <> "` cannot be " <> "executed. Try running\n" <>@@ -36,8 +38,8 @@ ScriptNotFound -> do mhError $ NoSuchScript scriptName -runScript :: STM.TChan ProgramOutput -> FilePath -> Text -> IO (Maybe (MH ()))-runScript outputChan fp text = do+runScript :: ChannelId -> STM.TChan ProgramOutput -> FilePath -> Text -> IO (Maybe (MH ()))+runScript cId outputChan fp text = do outputVar <- newEmptyMVar runLoggedCommand True outputChan fp [] (Just $ T.unpack text) (Just outputVar) po <- takeMVar outputVar@@ -46,7 +48,6 @@ case null $ programStderr po of True -> Just $ do mode <- use (csEditState.cedEditMode)- cId <- use csCurrentChannelId sendMessage cId mode (T.pack $ programStdout po) [] False -> Nothing ExitFailure _ -> Nothing
src/State/Async.hs view
@@ -123,7 +123,7 @@ -- main (brick) thread. doAsyncMM :: AsyncPriority -- ^ the priority for this async operation- -> (Session -> TeamId -> IO a)+ -> (Session -> IO a) -- ^ the async MM channel-based IO operation -> (a -> Maybe (MH ())) -- ^ function to process the results in brick event handling@@ -131,9 +131,8 @@ -> MH () doAsyncMM prio mmOp eventHandler = do session <- getSession- tId <- gets myTeamId doAsyncWith prio $ do- r <- mmOp session tId+ r <- mmOp session return $ eventHandler r -- | Helper type for a function to perform an asynchronous MM operation@@ -143,7 +142,7 @@ -- ^ the priority for this async operation -> ChannelId -- ^ The channel- -> (Session -> TeamId -> ChannelId -> IO a)+ -> (Session -> ChannelId -> IO a) -- ^ the asynchronous Mattermost channel-based IO operation -> (ChannelId -> a -> Maybe (MH ())) -- ^ function to process the results in brick event handling context@@ -154,7 +153,7 @@ -- an MH () context in the main (brick) thread. doAsyncChannelMM :: DoAsyncChannelMM a doAsyncChannelMM prio cId mmOp eventHandler =- doAsyncMM prio (\s t -> mmOp s t cId) (eventHandler cId)+ doAsyncMM prio (\s -> mmOp s cId) (eventHandler cId) -- | Use this convenience function if no operation needs to be -- performed in the MH state after an async operation completes.
src/State/Attachments.hs view
@@ -48,6 +48,6 @@ showAttachmentFileBrowser = do config <- use (csResources.crConfiguration) filePath <- liftIO $ defaultAttachmentsPath config- browser <- liftIO $ FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser filePath+ browser <- liftIO $ Just <$> FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser filePath csEditState.cedFileBrowser .= browser setMode ManageAttachmentsBrowseFiles
src/State/Channels.hs view
@@ -136,7 +136,7 @@ then use csRecentChannel else return Nothing doAsyncChannelMM Preempt cId- (\s _ c -> MM.mmViewChannel UserMe c pId s)+ (\s c -> MM.mmViewChannel UserMe c pId s) (\c () -> Just $ setLastViewedFor pId c) Disconnected -> -- Cannot update server; make no local updates to avoid getting@@ -219,7 +219,7 @@ -- updating the client data, but it's also immune to any new -- or removed Message date fields, or anything else that would -- contribute to the viewed/updated times on the server.- doAsyncChannelMM Preempt cId (\ s _ _ ->+ doAsyncChannelMM Preempt cId (\ s _ -> (,) <$> MM.mmGetChannel cId s <*> MM.mmGetChannelMember cId UserMe s) (\pcid (cwd, member) -> Just $ csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd member)@@ -709,7 +709,7 @@ -- that we aren't the only remaining member, so we can't -- delete the channel. doAsyncChannelMM Preempt cId- (\s _ _ ->+ (\s _ -> let query = MM.defaultUserQuery { MM.userQueryPage = Just 0 , MM.userQueryPerPage = Just 2@@ -726,15 +726,15 @@ -- by the delete argument. let func = case cInfo^.cdType of Private -> case all isMe members of- True -> (\ s _ c -> MM.mmDeleteChannel c s)- False -> (\ s _ c -> MM.mmRemoveUserFromChannel c UserMe s)+ True -> (\ s c -> MM.mmDeleteChannel c s)+ False -> (\ s c -> MM.mmRemoveUserFromChannel c UserMe s) Group ->- \s _ _ ->+ \s _ -> let pref = hideGroupChannelPref cId (me^.userIdL) in MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) s _ -> if delete- then (\ s _ c -> MM.mmDeleteChannel c s)- else (\ s _ c -> MM.mmRemoveUserFromChannel c UserMe s)+ then (\ s c -> MM.mmDeleteChannel c s)+ else (\ s c -> MM.mmRemoveUserFromChannel c UserMe s) doAsyncChannelMM Preempt cId func endAsyncNOP )@@ -934,7 +934,7 @@ myId <- gets myUserId let member = MinChannelMember myId chanId csPendingChannelChange .= (Just $ ChangeByChannelId chanId)- doAsyncChannelMM Preempt chanId (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP+ doAsyncChannelMM Preempt chanId (\ s c -> MM.mmAddUser c member s) endAsyncNOP createOrFocusDMChannel :: UserInfo -> Maybe (ChannelId -> MH ()) -> MH () createOrFocusDMChannel user successAct = do@@ -993,7 +993,7 @@ cId <- use csCurrentChannelId let patch = defaultChannelPatch { channelPatchHeader = Just msg } doAsyncChannelMM Preempt cId- (\s _ _ -> MM.mmPatchChannel cId patch s)+ (\s _ -> MM.mmPatchChannel cId patch s) (\_ _ -> Nothing) beginCurrentChannelDeleteConfirm :: MH ()
src/State/MessageSelect.hs view
@@ -220,7 +220,7 @@ case msg^.mOriginalPost of Just p -> doAsyncChannelMM Preempt cId- (\s _ _ -> MM.mmDeletePost (postId p) s)+ (\s _ -> MM.mmDeletePost (postId p) s) (\_ _ -> Just $ do csEditState.cedEditMode .= NewPost setMode Main)
src/State/Messages.hs view
@@ -543,7 +543,7 @@ case getMessageForPostId st parentId of Nothing -> do doAsyncChannelMM Preempt cId- (\s _ _ -> MM.mmGetThread parentId s)+ (\s _ -> MM.mmGetThread parentId s) (\_ p -> Just $ updatePostMap p) _ -> return () _ -> return ()@@ -702,7 +702,7 @@ addTrailingGap = MM.postQueryBefore query == Nothing && MM.postQueryPage query == Just 0 in doAsyncChannelMM Preempt cId- (\s _ c -> MM.mmGetPostsForChannel c query s)+ (\s c -> MM.mmGetPostsForChannel c query s) (\c p -> Just $ do pp <- addObtainedMessages c (-pageAmount) addTrailingGap p postProcessMessageAdd pp@@ -754,7 +754,7 @@ addTrailingGap = MM.postQueryBefore query == Nothing && MM.postQueryPage query == Just 0 in doAsyncChannelMM Preempt cId- (\s _ c -> MM.mmGetPostsForChannel c query s)+ (\s c -> MM.mmGetPostsForChannel c query s) (\c p -> Just $ do void $ addObtainedMessages c (-pageAmount) addTrailingGap p mh $ invalidateCacheEntry (ChannelMessages cId))@@ -784,7 +784,7 @@ reqAmt = 5 -- both before and after doAsyncChannelMM Preempt cId -- first get some messages before the target, no overlap- (\s _ c -> MM.mmGetPostsForChannel c query s)+ (\s c -> MM.mmGetPostsForChannel c query s) (\c p -> Just $ do let last2ndId = secondToLastPostId p void $ addObtainedMessages c (-reqAmt) False p@@ -798,7 +798,7 @@ , MM.postQueryPerPage = Just $ reqAmt + 2 } doAsyncChannelMM Preempt cId- (\s' _ c' -> MM.mmGetPostsForChannel c' query' s')+ (\s' c' -> MM.mmGetPostsForChannel c' query' s') (\c' p' -> Just $ do void $ addObtainedMessages c' (reqAmt + 2) False p' mh $ invalidateCacheEntry (ChannelMessages cId)@@ -832,7 +832,7 @@ finalQuery = case rel'pId of Just (MessagePostId pid) -> query { MM.postQueryBefore = Just pid } _ -> query- op = \s _ c -> MM.mmGetPostsForChannel c finalQuery s+ op = \s c -> MM.mmGetPostsForChannel c finalQuery s addTrailingGap = MM.postQueryBefore finalQuery == Nothing && MM.postQueryPage finalQuery == Just 0 in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do
src/State/Reactions.hs view
@@ -26,7 +26,7 @@ asyncFetchReactionsForPost cId p | not (p^.postHasReactionsL) = return () | otherwise = doAsyncChannelMM Normal cId- (\s _ _ -> fmap toList (mmGetReactionsForPost (p^.postIdL) s))+ (\s _ -> fmap toList (mmGetReactionsForPost (p^.postIdL) s)) (\_ rs -> Just $ addReactions cId rs) addReactions :: ChannelId -> [Reaction] -> MH ()
src/State/Users.hs view
@@ -28,7 +28,7 @@ handleNewUsers :: Seq UserId -> MH () -> MH () handleNewUsers newUserIds after = do doAsyncMM Preempt getUserInfo addNewUsers- where getUserInfo session _ =+ where getUserInfo session = do nUsers <- MM.mmGetUsersByIds newUserIds session let usrInfo u = userInfoFromUser u True usrList = toList nUsers
src/Types.hs view
@@ -938,8 +938,12 @@ , _cedAttachmentList :: List Name AttachmentData -- ^ The list of attachments to be uploaded with the -- post being edited.- , _cedFileBrowser :: FB.FileBrowser Name+ , _cedFileBrowser :: Maybe (FB.FileBrowser Name) -- ^ The browser for selecting attachment files.+ -- This is a Maybe because the instantiation of the+ -- FileBrowser causes it to read and ingest the+ -- target directory, so this action is deferred+ -- until the browser is needed. } -- | An attachment.@@ -952,8 +956,7 @@ -- | We can initialize a new 'ChatEditState' value with just an edit -- history, which we save locally. emptyEditState :: InputHistory -> Maybe (Aspell, IO ()) -> IO ChatEditState-emptyEditState hist sp = do- browser <- FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser Nothing+emptyEditState hist sp = return ChatEditState { _cedEditor = editor MessageInput Nothing "" , _cedEphemeral = defaultEphemeralEditState , _cedInputHistory = hist@@ -964,7 +967,7 @@ , _cedAutocomplete = Nothing , _cedAutocompletePending = Nothing , _cedAttachmentList = list AttachmentList mempty 1- , _cedFileBrowser = browser+ , _cedFileBrowser = Nothing } -- | A 'RequestChan' is a queue of operations we have to perform in the
src/Types/Messages.hs view
@@ -496,9 +496,10 @@ retrogradeMsgsWithThreadStates msgs = DSeq $ checkAdjacentMessages (dseq msgs) where getMessagePredecessor ms =+ let visiblePredMsg m = not (isTransition m || m^.mDeleted) in case Seq.viewl ms of prev Seq.:< rest ->- if not $ isTransition prev+ if visiblePredMsg prev then Just prev else getMessagePredecessor rest Seq.EmptyL -> Nothing@@ -519,9 +520,10 @@ chronologicalMsgsWithThreadStates msgs = DSeq $ checkAdjacentMessages (dseq msgs) where getMessagePredecessor ms =+ let visiblePredMsg m = not (isTransition m || m^.mDeleted) in case Seq.viewr ms of rest Seq.:> prev ->- if not $ isTransition prev+ if visiblePredMsg prev then Just prev else getMessagePredecessor rest Seq.EmptyR -> Nothing