diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ========= diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 = diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -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) } diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -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") $ diff --git a/src/Draw/ManageAttachments.hs b/src/Draw/ManageAttachments.hs --- a/src/Draw/ManageAttachments.hs +++ b/src/Draw/ManageAttachments.hs @@ -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) diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -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, **" diff --git a/src/Events/ManageAttachments.hs b/src/Events/ManageAttachments.hs --- a/src/Events/ManageAttachments.hs +++ b/src/Events/ManageAttachments.hs @@ -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 diff --git a/src/Scripts.hs b/src/Scripts.hs --- a/src/Scripts.hs +++ b/src/Scripts.hs @@ -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 diff --git a/src/State/Async.hs b/src/State/Async.hs --- a/src/State/Async.hs +++ b/src/State/Async.hs @@ -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. diff --git a/src/State/Attachments.hs b/src/State/Attachments.hs --- a/src/State/Attachments.hs +++ b/src/State/Attachments.hs @@ -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 diff --git a/src/State/Channels.hs b/src/State/Channels.hs --- a/src/State/Channels.hs +++ b/src/State/Channels.hs @@ -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 () diff --git a/src/State/MessageSelect.hs b/src/State/MessageSelect.hs --- a/src/State/MessageSelect.hs +++ b/src/State/MessageSelect.hs @@ -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) diff --git a/src/State/Messages.hs b/src/State/Messages.hs --- a/src/State/Messages.hs +++ b/src/State/Messages.hs @@ -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 diff --git a/src/State/Reactions.hs b/src/State/Reactions.hs --- a/src/State/Reactions.hs +++ b/src/State/Reactions.hs @@ -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 () diff --git a/src/State/Users.hs b/src/State/Users.hs --- a/src/State/Users.hs +++ b/src/State/Users.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Types/Messages.hs b/src/Types/Messages.hs --- a/src/Types/Messages.hs +++ b/src/Types/Messages.hs @@ -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