diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,23 @@ +50200.15.0 +========== + +New features: + * Matterhorn now supports getting post permalinks (#677). A new `l` + binding in message selection mode was added to copy a post's link to + the clipboard. + +Bug fixes and improvements: + * Matterhorn now properly displays the active configured keybinding, + rather than the default, in more places where keybinding hints are + shown in the UI. + * The URL list (`C-o`) now only shows URLs mentioned in messages that + have not been deleted (#749). + * Matterhorn no longer reports HTTP 503 and 504 errors as unhandled + exceptions. + * The login UI now displays Mattermost server errors more cleanly + (#741). + 50200.14.1 ========== diff --git a/docs/keybindings.md b/docs/keybindings.md --- a/docs/keybindings.md +++ b/docs/keybindings.md @@ -99,6 +99,7 @@ | `f` | `flag-message` | Flag the selected message | | `v` | `view-message` | View the selected message | | `Enter` | `fetch-for-gap` | Fetch messages for the selected gap | +| `l` | `copy-post-link` | Copy a post's link to the clipboard | | `a` | `react-to-message` | Post a reaction to the selected message | # User Listings diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 50200.14.1 +version: 50200.15.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 @@ -101,7 +101,6 @@ Matterhorn.HelpTopics Matterhorn.IOUtil Matterhorn.InputHistory - Matterhorn.KeyMap Matterhorn.LastRunState Matterhorn.Login Matterhorn.Options diff --git a/programs/Main.hs b/programs/Main.hs --- a/programs/Main.hs +++ b/programs/Main.hs @@ -10,9 +10,9 @@ import Matterhorn.Options import Matterhorn.App import Matterhorn.Events.Keybindings ( ensureKeybindingConsistency ) -import Matterhorn.KeyMap ( keybindingModeMap ) import Matterhorn.Draw.ShowHelp ( keybindingMarkdownTable, keybindingTextTable - , commandMarkdownTable, commandTextTable ) + , commandMarkdownTable, commandTextTable + , keybindSections ) main :: IO () @@ -50,7 +50,7 @@ when (printedKeybindings || printedCommands) exitSuccess - case ensureKeybindingConsistency keyConfig keybindingModeMap of + case ensureKeybindingConsistency keyConfig keybindSections of Right () -> return () Left err -> do putStrLn $ "Configuration error: " <> err diff --git a/src/Matterhorn/Draw/Main.hs b/src/Matterhorn/Draw/Main.hs --- a/src/Matterhorn/Draw/Main.hs +++ b/src/Matterhorn/Draw/Main.hs @@ -273,7 +273,8 @@ ] _ -> emptyWidget - multiLineToggleKey = ppBinding $ getFirstDefaultBinding ToggleMultiLineEvent + kc = st^.csResources.crConfiguration.configUserKeysL + multiLineToggleKey = ppBinding $ firstActiveBinding kc ToggleMultiLineEvent commandBox = case st^.csCurrentTeam.tsEditState.cedEphemeral.eesMultiline of False -> @@ -630,6 +631,10 @@ , ev FlagMessageEvent , "unflag" ) + , ( isPostMessage + , ev CopyPostLinkEvent + , "copy-link" + ) , ( \m -> isPinnable m && not (m^.mPinned) , ev PinMessageEvent , "pin" @@ -823,6 +828,7 @@ , showBusy ] + kc = st^.csResources.crConfiguration.configUserKeysL showAttachmentCount = let count = length $ listElements $ st^.csCurrentTeam.tsEditState.cedAttachmentList in if count == 0 @@ -832,7 +838,7 @@ txt $ "(" <> (T.pack $ show count) <> " attachment" <> (if count == 1 then "" else "s") <> "; " , withDefAttr clientEmphAttr $ - txt $ ppBinding (getFirstDefaultBinding ShowAttachmentListEvent) + txt $ ppBinding (firstActiveBinding kc ShowAttachmentListEvent) , txt " to manage)" ] diff --git a/src/Matterhorn/Draw/ManageAttachments.hs b/src/Matterhorn/Draw/ManageAttachments.hs --- a/src/Matterhorn/Draw/ManageAttachments.hs +++ b/src/Matterhorn/Draw/ManageAttachments.hs @@ -15,7 +15,7 @@ import Matterhorn.Types import Matterhorn.Types.KeyEvents -import Matterhorn.Events.Keybindings ( getFirstDefaultBinding ) +import Matterhorn.Events.Keybindings ( firstActiveBinding ) import Matterhorn.Themes @@ -30,10 +30,11 @@ drawAttachmentList :: ChatState -> Widget Name drawAttachmentList st = - let addBinding = ppBinding $ getFirstDefaultBinding AttachmentListAddEvent - delBinding = ppBinding $ getFirstDefaultBinding AttachmentListDeleteEvent - escBinding = ppBinding $ getFirstDefaultBinding CancelEvent - openBinding = ppBinding $ getFirstDefaultBinding AttachmentOpenEvent + let addBinding = ppBinding $ firstActiveBinding kc AttachmentListAddEvent + delBinding = ppBinding $ firstActiveBinding kc AttachmentListDeleteEvent + escBinding = ppBinding $ firstActiveBinding kc CancelEvent + openBinding = ppBinding $ firstActiveBinding kc AttachmentOpenEvent + kc = st^.csResources.crConfiguration.configUserKeysL in centerLayer $ hLimit 60 $ vLimit 15 $ diff --git a/src/Matterhorn/Draw/NotifyPrefs.hs b/src/Matterhorn/Draw/NotifyPrefs.hs --- a/src/Matterhorn/Draw/NotifyPrefs.hs +++ b/src/Matterhorn/Draw/NotifyPrefs.hs @@ -22,8 +22,8 @@ let Just form = st^.csCurrentTeam.tsNotifyPrefs label = forceAttr clientEmphAttr $ str "Notification Preferences" formKeys = withDefAttr clientEmphAttr <$> txt <$> ["Tab", "BackTab"] - bindings = vBox $ hCenter <$> [ renderKeybindingHelp "Save" [FormSubmitEvent] <+> txt " " <+> - renderKeybindingHelp "Cancel" [CancelEvent] + bindings = vBox $ hCenter <$> [ renderKeybindingHelp st "Save" [FormSubmitEvent] <+> txt " " <+> + renderKeybindingHelp st "Cancel" [CancelEvent] , hBox ((intersperse (txt "/") formKeys) <> [txt (":Cycle form fields")]) , hBox [withDefAttr clientEmphAttr $ txt "Space", txt ":Toggle form field"] ] diff --git a/src/Matterhorn/Draw/ShowHelp.hs b/src/Matterhorn/Draw/ShowHelp.hs --- a/src/Matterhorn/Draw/ShowHelp.hs +++ b/src/Matterhorn/Draw/ShowHelp.hs @@ -4,6 +4,7 @@ , keybindingTextTable , commandTextTable , commandMarkdownTable + , keybindSections ) where @@ -250,8 +251,8 @@ , "values, are as follows:" ] ] - nextChanBinding = ppBinding (getFirstDefaultBinding NextChannelEvent) - prevChanBinding = ppBinding (getFirstDefaultBinding PrevChannelEvent) + nextChanBinding = ppBinding (firstActiveBinding kc NextChannelEvent) + prevChanBinding = ppBinding (firstActiveBinding kc PrevChannelEvent) validKeys = map paraL [ [ "The syntax used for key sequences consists of zero or more " , "single-character modifier characters followed by a keystroke, " diff --git a/src/Matterhorn/Draw/TabbedWindow.hs b/src/Matterhorn/Draw/TabbedWindow.hs --- a/src/Matterhorn/Draw/TabbedWindow.hs +++ b/src/Matterhorn/Draw/TabbedWindow.hs @@ -34,15 +34,15 @@ hLimit (twWindowWidth w) $ joinBorders $ borderWithLabel title $ - (tabBar tId w <=> tabBody <=> hBorder <=> hCenter keybindingHelp) + (tabBar tId w <=> tabBody <=> hBorder <=> hCenter (keybindingHelp cs)) -- | Keybinding help to show at the bottom of a tabbed window. -keybindingHelp :: Widget Name -keybindingHelp = +keybindingHelp :: ChatState -> Widget Name +keybindingHelp st = let pairs = [ ("Switch tabs", [SelectNextTabEvent, SelectPreviousTabEvent]) , ("Scroll", [ScrollUpEvent, ScrollDownEvent, ScrollLeftEvent, ScrollRightEvent, PageLeftEvent, PageRightEvent]) ] - in hBox $ intersperse (txt " ") $ (uncurry renderKeybindingHelp) <$> pairs + in hBox $ intersperse (txt " ") $ (uncurry (renderKeybindingHelp st)) <$> pairs -- | The scrollable tab bar to show at the top of a tabbed window. tabBar :: (Eq a, Show a) diff --git a/src/Matterhorn/Draw/ThemeListOverlay.hs b/src/Matterhorn/Draw/ThemeListOverlay.hs --- a/src/Matterhorn/Draw/ThemeListOverlay.hs +++ b/src/Matterhorn/Draw/ThemeListOverlay.hs @@ -37,8 +37,9 @@ , close , txt ":close" ]) - enter = emph $ txt $ ppBinding (getFirstDefaultBinding ActivateListItemEvent) - close = emph $ txt $ ppBinding (getFirstDefaultBinding CancelEvent) + enter = emph $ txt $ ppBinding (firstActiveBinding kc ActivateListItemEvent) + close = emph $ txt $ ppBinding (firstActiveBinding kc CancelEvent) + kc = st^.csResources.crConfiguration.configUserKeysL emph = withDefAttr clientEmphAttr in joinBorders overlay diff --git a/src/Matterhorn/Draw/Util.hs b/src/Matterhorn/Draw/Util.hs --- a/src/Matterhorn/Draw/Util.hs +++ b/src/Matterhorn/Draw/Util.hs @@ -25,7 +25,7 @@ import Matterhorn.TimeUtils import Matterhorn.Types import Matterhorn.Types.KeyEvents -import Matterhorn.Events.Keybindings ( getFirstDefaultBinding ) +import Matterhorn.Events.Keybindings ( firstActiveBinding ) defaultTimeFormat :: Text @@ -57,9 +57,10 @@ then emptyWidget else withDefAttr timeAttr (txt $ localTimeText fmt $ asLocalTime tz t) -renderKeybindingHelp :: Text -> [KeyEvent] -> Widget Name -renderKeybindingHelp label evs = - let ppEv ev = withDefAttr clientEmphAttr $ txt (ppBinding (getFirstDefaultBinding ev)) +renderKeybindingHelp :: ChatState -> Text -> [KeyEvent] -> Widget Name +renderKeybindingHelp st label evs = + let ppEv ev = withDefAttr clientEmphAttr $ txt (ppBinding (firstActiveBinding kc ev)) + kc = st^.csResources.crConfiguration.configUserKeysL in hBox $ (intersperse (txt "/") $ ppEv <$> evs) <> [txt (":" <> label)] -- | Modifies a message sequence by inserting date transition markers diff --git a/src/Matterhorn/Events/Keybindings.hs b/src/Matterhorn/Events/Keybindings.hs --- a/src/Matterhorn/Events/Keybindings.hs +++ b/src/Matterhorn/Events/Keybindings.hs @@ -1,7 +1,7 @@ module Matterhorn.Events.Keybindings ( defaultBindings , lookupKeybinding - , getFirstDefaultBinding + , firstActiveBinding , mkKb , staticKb @@ -129,7 +129,10 @@ } mkKeybindings :: [KeyEventHandler] -> KeyConfig -> KeyHandlerMap -mkKeybindings ks conf = KeyHandlerMap $ M.fromList pairs +mkKeybindings ks conf = KeyHandlerMap $ M.fromList $ keyHandlerMapPairs ks conf + +keyHandlerMapPairs :: [KeyEventHandler] -> KeyConfig -> [(Vty.Event, KeyHandler)] +keyHandlerMapPairs ks conf = pairs where pairs = mkPair <$> handlers mkPair h = (khKey h, h) @@ -139,6 +142,13 @@ bindingToEvent binding = Vty.EvKey (kbKey binding) (kbMods binding) +firstActiveBinding :: KeyConfig -> KeyEvent -> Binding +firstActiveBinding kc ev = fromMaybe (getFirstDefaultBinding ev) $ do + bState <- M.lookup ev kc + case bState of + BindingList (b:_) -> Just b + _ -> Nothing + getFirstDefaultBinding :: KeyEvent -> Binding getFirstDefaultBinding ev = case defaultBindings ev of @@ -198,6 +208,7 @@ SearchSelectDownEvent -> [ ctrl (key 'n'), kb Vty.KDown ] ViewMessageEvent -> [ key 'v' ] FillGapEvent -> [ kb Vty.KEnter ] + CopyPostLinkEvent -> [ key 'l' ] FlagMessageEvent -> [ key 'f' ] PinMessageEvent -> [ key 'p' ] YankMessageEvent -> [ key 'y' ] @@ -249,7 +260,7 @@ -- basic usability (i.e. we shouldn't be binding events which can appear -- in the main UI to a key like @e@, which would prevent us from being -- able to type messages containing an @e@ in them! -ensureKeybindingConsistency :: KeyConfig -> [(String, KeyConfig -> KeyHandlerMap)] -> Either String () +ensureKeybindingConsistency :: KeyConfig -> [(T.Text, [KeyEventHandler])] -> Either String () ensureKeybindingConsistency kc modeMaps = mapM_ checkGroup allBindings where -- This is a list of lists, grouped by keybinding, of all the @@ -274,7 +285,7 @@ -- We find out which modes an event can be used in and then invert -- the map, so this is a map from mode to the events contains -- which are bound by the binding included above. - let modesFor :: M.Map String [(Bool, KeyEvent)] + let modesFor :: M.Map T.Text [(Bool, KeyEvent)] modesFor = M.unionsWith (++) [ M.fromList [ (m, [(i, ev)]) | m <- modeMap ev ] | (_, (i, ev)) <- evs @@ -288,14 +299,14 @@ forM_ (M.assocs modesFor) $ \ (_, vs) -> when (length vs > 1) $ Left $ concat $ - "Multiple overlapping events bound to `" : + "Multiple overlapping key events bound to `" : T.unpack (ppBinding b) : "`:\n" : concat [ [ " - `" , T.unpack (keyEventName ev) , "` " , if isFromUser - then "(via user override)" + then "(via user configuration)" else "(matterhorn default)" , "\n" ] @@ -329,11 +340,11 @@ -- We generate the which-events-are-valid-in-which-modes map from -- our actual keybinding set, so this should never get out of date. - modeMap :: KeyEvent -> [String] + modeMap :: KeyEvent -> [T.Text] modeMap ev = let matches kh = ByEvent ev == (kehEventTrigger $ khHandler kh) in [ mode - | (mode, mkBindings) <- modeMaps - , let KeyHandlerMap m = mkBindings kc - in not $ null $ M.filter matches m + | (mode, handlers) <- modeMaps + , let pairs = keyHandlerMapPairs handlers kc + in not $ null $ filter matches $ snd <$> pairs ] 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 @@ -85,6 +85,9 @@ , mkKb FillGapEvent "Fetch messages for the selected gap" fillSelectedGap + , mkKb CopyPostLinkEvent "Copy a post's link to the clipboard" + copyPostLink + , mkKb ReactToMessageEvent "Post a reaction to the selected message" enterReactionEmojiListOverlayMode diff --git a/src/Matterhorn/KeyMap.hs b/src/Matterhorn/KeyMap.hs deleted file mode 100644 --- a/src/Matterhorn/KeyMap.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Matterhorn.KeyMap - ( keybindingModeMap - ) -where - -import Prelude () -import Matterhorn.Prelude - -import Matterhorn.Events.Keybindings -import Matterhorn.Events.ChannelSelect -import Matterhorn.Events.Main -import Matterhorn.Events.MessageSelect -import Matterhorn.Events.PostListOverlay -import Matterhorn.Events.ShowHelp -import Matterhorn.Events.UrlSelect -import Matterhorn.Events.ManageAttachments - -keybindingModeMap :: [(String, KeyConfig -> KeyHandlerMap)] -keybindingModeMap = - [ ("main", mainKeybindings) - , ("help screen", helpKeybindings) - , ("channel select", channelSelectKeybindings) - , ("url select", urlSelectKeybindings) - , ("message select", messageSelectKeybindings) - , ("post list overlay", postListOverlayKeybindings) - , ("attachment list", attachmentListKeybindings) - , ("attachment file browse", attachmentBrowseKeybindings) - ] diff --git a/src/Matterhorn/Login.hs b/src/Matterhorn/Login.hs --- a/src/Matterhorn/Login.hs +++ b/src/Matterhorn/Login.hs @@ -78,7 +78,7 @@ import Network.Mattermost.Types.Internal ( Token(..) ) import Network.Mattermost.Types ( Session(..), User, Login(..), ConnectionPoolConfig(..) , initConnectionData, ConnectionType(..), UserParam(..) ) -import Network.Mattermost.Exceptions ( LoginFailureException(..) ) +import Network.Mattermost.Exceptions ( LoginFailureException(..), MattermostError(..) ) import Network.Mattermost.Endpoints ( mmGetUser, mmGetLimitedClientConfiguration, mmLogin ) import Matterhorn.Draw.RichText @@ -167,6 +167,7 @@ `catch` (\e -> return $ Left $ ResolveError e) `catch` (\e -> return $ Left $ ConnectError e) `catchIOError` (\e -> return $ Left $ AuthIOError e) + `catch` (\e -> return $ Left $ MattermostServerError e) `catch` (\e -> return $ Left $ OtherAuthError e) -- | The login worker thread. @@ -572,6 +573,8 @@ "Could not connect to server" renderAuthError (ResolveError _) = "Could not resolve server hostname" +renderAuthError (MattermostServerError e) = + mattermostErrorMessage e renderAuthError (AuthIOError err) | Err.isDoesNotExistErrorType (Err.ioeGetErrorType err) = "Unable to connect to the network" diff --git a/src/Matterhorn/Options.hs b/src/Matterhorn/Options.hs --- a/src/Matterhorn/Options.hs +++ b/src/Matterhorn/Options.hs @@ -57,8 +57,8 @@ (ReqArg (\ path c -> c { optConfLocation = Just path }) "PATH") "Path to the configuration file" , Option ['l'] ["logs"] - (ReqArg (\ path c -> c { optLogLocation = Just path }) "PATH") - "Debug log output path" + (ReqArg (\ path c -> c { optLogLocation = Just path }) "FILE") + "Path to debug log output file" , Option ['v'] ["version"] (NoArg (\ c -> c { optBehaviour = ShowVersion })) "Print version information and exit" 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 @@ -164,73 +164,77 @@ (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) return $ st & csChannels %~ modifyChannelById cId addEMsg -openFilePath :: FilePath -> MH Bool -openFilePath path = openWithOpener (return path) +openFilePath :: FilePath -> MH () +openFilePath path = openWithOpener (return $ Right path) -openWithOpener :: MH String -> MH Bool +openWithOpener :: MH (Either MHError String) -> MH () openWithOpener getTarget = do cfg <- use (csResources.crConfiguration) case configURLOpenCommand cfg of Nothing -> - return False + mhError $ ConfigOptionMissing "urlOpenCommand" Just urlOpenCommand -> do - target <- getTarget + targetResult <- getTarget - -- Is the URL-opening command interactive? If so, pause - -- Matterhorn and run the opener interactively. Otherwise - -- run the opener asynchronously and continue running - -- Matterhorn interactively. - case configURLOpenCommandInteractive cfg of - False -> do - outputChan <- use (csResources.crSubprocessLog) - doAsyncWith Preempt $ do - runLoggedCommand outputChan (T.unpack urlOpenCommand) - [target] Nothing Nothing - return Nothing - True -> do - -- If there isn't a new message cutoff showing in - -- the current channel, set one. This way, while the - -- user is gone using their interactive URL opener, - -- when they return, any messages that arrive in the - -- current channel will be displayed as new. - curChan <- use csCurrentChannel - let msgs = curChan^.ccContents.cdMessages - case findLatestUserMessage isEditable msgs of - Nothing -> return () - Just m -> - case m^.mOriginalPost of + case targetResult of + Left e -> do + mhError e + Right target -> do + -- Is the URL-opening command interactive? If + -- so, pause Matterhorn and run the opener + -- interactively. Otherwise run the opener + -- asynchronously and continue running Matterhorn + -- interactively. + case configURLOpenCommandInteractive cfg of + False -> do + outputChan <- use (csResources.crSubprocessLog) + doAsyncWith Preempt $ do + runLoggedCommand outputChan (T.unpack urlOpenCommand) + [target] Nothing Nothing + return Nothing + True -> do + -- If there isn't a new message cutoff + -- showing in the current channel, set one. + -- This way, while the user is gone using + -- their interactive URL opener, when they + -- return, any messages that arrive in the + -- current channel will be displayed as new. + curChan <- use csCurrentChannel + let msgs = curChan^.ccContents.cdMessages + case findLatestUserMessage isEditable msgs of Nothing -> return () - Just p -> - case curChan^.ccInfo.cdNewMessageIndicator of - Hide -> - csCurrentChannel.ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL)) - _ -> return () - -- No need to add a gap here: the websocket - -- disconnect/reconnect events will automatically - -- handle management of messages delivered while - -- suspended. - - mhSuspendAndResume $ \st -> do - result <- runInteractiveCommand (T.unpack urlOpenCommand) [target] + Just m -> + case m^.mOriginalPost of + Nothing -> return () + Just p -> + case curChan^.ccInfo.cdNewMessageIndicator of + Hide -> + csCurrentChannel.ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL)) + _ -> return () + -- No need to add a gap here: the websocket + -- disconnect/reconnect events will + -- automatically handle management of + -- messages delivered while suspended. - let waitForKeypress = do - putStrLn "Press any key to return to Matterhorn." - void getChar + mhSuspendAndResume $ \st -> do + result <- runInteractiveCommand (T.unpack urlOpenCommand) [target] - case result of - Right ExitSuccess -> return () - Left err -> do - putStrLn $ "URL opener subprocess " <> (show urlOpenCommand) <> - " could not be run: " <> err - waitForKeypress - Right (ExitFailure code) -> do - putStrLn $ "URL opener subprocess " <> (show urlOpenCommand) <> - " exited with non-zero status " <> show code - waitForKeypress + let waitForKeypress = do + putStrLn "Press any key to return to Matterhorn." + void getChar - return $ setMode' Main st + case result of + Right ExitSuccess -> return () + Left err -> do + putStrLn $ "URL opener subprocess " <> (show urlOpenCommand) <> + " could not be run: " <> err + waitForKeypress + Right (ExitFailure code) -> do + putStrLn $ "URL opener subprocess " <> (show urlOpenCommand) <> + " exited with non-zero status " <> show code + waitForKeypress - return True + return $ setMode' Main st runInteractiveCommand :: String -> [String] diff --git a/src/Matterhorn/State/Links.hs b/src/Matterhorn/State/Links.hs --- a/src/Matterhorn/State/Links.hs +++ b/src/Matterhorn/State/Links.hs @@ -6,18 +6,28 @@ import Prelude () import Matterhorn.Prelude +import Control.Exception ( SomeException, catch ) import qualified Data.Text as T +import Network.Mattermost.Exceptions +import Network.Mattermost.Types + import Matterhorn.State.Common import Matterhorn.State.Messages ( jumpToPost ) import Matterhorn.Types import Matterhorn.Types.RichText ( unURL ) -openLinkTarget :: LinkTarget -> MH Bool +openLinkTarget :: LinkTarget -> MH () openLinkTarget target = do session <- getSession case target of - LinkURL url -> openWithOpener (return $ T.unpack $ unURL url) - LinkFileId fId -> openWithOpener (liftIO $ fetchFile fId session) - LinkPermalink _ pId -> jumpToPost pId >> return True + LinkURL url -> openWithOpener (return $ Right $ T.unpack $ unURL url) + LinkFileId fId -> openWithOpener (fetchAttachment fId session) + LinkPermalink _ pId -> jumpToPost pId + +fetchAttachment :: FileId -> Session -> MH (Either MHError String) +fetchAttachment fId session = + liftIO $ (Right <$> fetchFile fId session) + `catch` (\(e::MattermostError) -> return $ Left $ ServerError e) + `catch` (\(e::SomeException) -> return $ Left $ GenericError $ T.pack $ show e) 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 @@ , pinSelectedMessage , viewSelectedMessage , fillSelectedGap + , copyPostLink , yankSelectedMessageVerbatim , yankSelectedMessage , openSelectedMessageURLs @@ -40,7 +41,7 @@ import Matterhorn.State.Links import Matterhorn.State.Messages import Matterhorn.Types -import Matterhorn.Types.RichText ( findVerbatimChunk ) +import Matterhorn.Types.RichText ( findVerbatimChunk, makePermalink ) import Matterhorn.Types.Common import Matterhorn.Windows.ViewMessage @@ -112,6 +113,18 @@ | not (isGap msg) -> viewMessage msg _ -> return () +copyPostLink :: MH () +copyPostLink = do + selected <- use (to getSelectedMessage) + case selected of + Just msg | isPostMessage msg -> do + tId <- use csCurrentTeamId + baseUrl <- getServerBaseUrl tId + let Just pId = messageIdPostId =<< _mMessageId msg + copyToClipboard $ makePermalink baseUrl pId + setMode Main + _ -> return () + fillSelectedGap :: MH () fillSelectedGap = do selected <- use (to getSelectedMessage) @@ -159,11 +172,7 @@ let urls = msgURLs curMsg when (not (null urls)) $ do - openedAll <- and <$> mapM (openLinkTarget . _linkTarget) urls - case openedAll of - True -> return () - False -> - mhError $ ConfigOptionMissing "urlOpenCommand" + mapM_ (openLinkTarget . _linkTarget) urls beginConfirmDeleteSelectedMessage :: MH () beginConfirmDeleteSelectedMessage = do 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 @@ -2,7 +2,6 @@ module Matterhorn.State.Messages ( PostToAdd(..) - , addDisconnectGaps , lastMsg , sendMessage , editMessage @@ -206,16 +205,17 @@ addNewPostedMessage p = addMessageToState True True p >>= postProcessMessageAdd --- | Adds the set of Posts to the indicated channel. The Posts must --- all be for the specified Channel. The reqCnt argument indicates --- how many posts were requested, which will determine whether a gap --- message is added to either end of the posts list or not. +-- | Adds the set of Posts to the indicated channel. The Posts must all +-- be for the specified Channel. The reqCnt argument indicates how many +-- posts were requested, which will determine whether a gap message is +-- added to either end of the posts list or not. -- --- The addTrailingGap is only True when fetching the very latest messages --- for the channel, and will suppress the generation of a Gap message --- following the added block of messages. +-- The addTrailingGap is only True when fetching the very latest +-- messages for the channel, and will suppress the generation of a Gap +-- message following the added block of messages. addObtainedMessages :: ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd -addObtainedMessages cId reqCnt addTrailingGap posts = +addObtainedMessages cId reqCnt addTrailingGap posts = do + mh $ invalidateCacheEntry (ChannelMessages cId) if null $ posts^.postsOrderL then do when addTrailingGap $ -- Fetched at the end of the channel, but nothing was @@ -807,8 +807,7 @@ (\s c -> MM.mmGetPostsForChannel c query s) (\c p -> Just $ do pp <- addObtainedMessages c (-pageAmount) addTrailingGap p - postProcessMessageAdd pp - mh $ invalidateCacheEntry (ChannelMessages cId)) + postProcessMessageAdd pp) -- | Given a starting point and a direction to move from that point, @@ -858,8 +857,7 @@ in doAsyncChannelMM Preempt cId (\s c -> MM.mmGetPostsForChannel c query s) (\c p -> Just $ do - void $ addObtainedMessages c (-pageAmount) addTrailingGap p - mh $ invalidateCacheEntry (ChannelMessages cId)) + void $ addObtainedMessages c (-pageAmount) addTrailingGap p) -- | Given a particular message ID, this fetches n messages before and -- after immediately before and after the specified message in order @@ -890,7 +888,6 @@ (\c p -> Just $ do let last2ndId = secondToLastPostId p void $ addObtainedMessages c (-reqAmt) False p - mh $ invalidateCacheEntry (ChannelMessages cId) -- now start 2nd from end of this fetch to fetch some -- messages forward, also overlapping with this fetch and -- the original message ID to eliminate all gaps in this @@ -903,34 +900,37 @@ (\s' c' -> MM.mmGetPostsForChannel c' query' s') (\c' p' -> Just $ do void $ addObtainedMessages c' (reqAmt + 2) False p' - mh $ invalidateCacheEntry (ChannelMessages cId) ) ) where secondToLastPostId posts = let pl = toList $ postsOrder posts in if length pl > 1 then Just $ last $ init pl else Nothing - fetchVisibleIfNeeded :: MH () fetchVisibleIfNeeded = do sts <- use csConnectionStatus when (sts == Connected) $ do tId <- use csCurrentTeamId cId <- use (csCurrentChannelId tId) - withChannel cId $ \chan -> + withChannel cId $ \chan -> do let msgs = chan^.ccContents.cdMessages.to reverseMessages (numRemaining, gapInDisplayable, _, rel'pId, overlap) = foldl gapTrail (numScrollbackPosts, False, Nothing, Nothing, 2) msgs + + gapTrail :: (Int, Bool, Maybe MessageId, Maybe MessageId, Int) + -> Message + -> (Int, Bool, Maybe MessageId, Maybe MessageId, Int) gapTrail a@(_, True, _, _, _) _ = a gapTrail a@(0, _, _, _, _) _ = a gapTrail (a, False, b, c, d) m | isGap m = (a, True, b, c, d) gapTrail (remCnt, _, prev'pId, prev''pId, ovl) msg = (remCnt - 1, False, msg^.mMessageId <|> prev'pId, prev'pId <|> prev''pId, ovl + if not (isPostMessage msg) then 1 else 0) - numToReq = numRemaining + overlap + + numToRequest = numRemaining + overlap query = MM.defaultPostQuery { MM.postQueryPage = Just 0 - , MM.postQueryPerPage = Just numToReq + , MM.postQueryPerPage = Just numToRequest } finalQuery = case rel'pId of Just (MessagePostId pid) -> query { MM.postQueryBefore = Just pid } @@ -938,12 +938,13 @@ 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 - csChannel(cId).ccContents.cdFetchPending .= True - doAsyncChannelMM Preempt cId op - (\c p -> Just $ do - addObtainedMessages c (-numToReq) addTrailingGap p >>= postProcessMessageAdd - csChannel(c).ccContents.cdFetchPending .= False) + + when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do + csChannel(cId).ccContents.cdFetchPending .= True + doAsyncChannelMM Preempt cId op + (\c p -> Just $ do + csChannel(c).ccContents.cdFetchPending .= False + addObtainedMessages c (-numToRequest) addTrailingGap p >>= postProcessMessageAdd) asyncFetchAttachments :: Post -> MH () asyncFetchAttachments p = do diff --git a/src/Matterhorn/State/Setup/Threads.hs b/src/Matterhorn/State/Setup/Threads.hs --- a/src/Matterhorn/State/Setup/Threads.hs +++ b/src/Matterhorn/State/Setup/Threads.hs @@ -367,11 +367,17 @@ shouldIgnore :: SomeException -> Bool shouldIgnore e = let eStr = show e - in or [ "getAddrInfo" `isInfixOf` eStr - , "Network.Socket.recvBuf" `isInfixOf` eStr - , "Network.Socket.sendBuf" `isInfixOf` eStr - , "resource vanished" `isInfixOf` eStr - , "timeout" `isInfixOf` eStr - , "partial packet" `isInfixOf` eStr - , "No route to host" `isInfixOf` eStr - ] + in or $ (`isInfixOf` eStr) <$> ignoreErrorSubstrings + +ignoreErrorSubstrings :: [String] +ignoreErrorSubstrings = + [ "getAddrInfo" + , "Network.Socket.recvBuf" + , "Network.Socket.sendBuf" + , "resource vanished" + , "timeout" + , "partial packet" + , "No route to host" + , "(5,0,3)" + , "(5,0,4)" + ] diff --git a/src/Matterhorn/State/UrlSelect.hs b/src/Matterhorn/State/UrlSelect.hs --- a/src/Matterhorn/State/UrlSelect.hs +++ b/src/Matterhorn/State/UrlSelect.hs @@ -34,16 +34,13 @@ openSelectedURL = whenMode UrlSelect $ do selected <- use (csCurrentTeam.tsUrlList.to listSelectedElement) case selected of - Nothing -> setMode Main - Just (_, (_, link)) -> do - opened <- openLinkTarget (link^.linkTarget) - when (not opened) $ do - mhError $ ConfigOptionMissing "urlOpenCommand" - setMode Main + Nothing -> return () + Just (_, (_, link)) -> openLinkTarget (link^.linkTarget) + setMode Main findUrls :: ClientChannel -> [LinkChoice] findUrls chan = - let msgs = chan^.ccContents.cdMessages + let msgs = filterMessages (not . _mDeleted) $ chan^.ccContents.cdMessages in removeDuplicates $ concat $ toList $ toList <$> msgURLs <$> msgs removeDuplicates :: [LinkChoice] -> [LinkChoice] diff --git a/src/Matterhorn/Types.hs b/src/Matterhorn/Types.hs --- a/src/Matterhorn/Types.hs +++ b/src/Matterhorn/Types.hs @@ -917,6 +917,7 @@ | ResolveError HostNotResolved | AuthIOError IOError | LoginError LoginFailureException + | MattermostServerError MattermostError | OtherAuthError SomeException deriving (Show) diff --git a/src/Matterhorn/Types/KeyEvents.hs b/src/Matterhorn/Types/KeyEvents.hs --- a/src/Matterhorn/Types/KeyEvents.hs +++ b/src/Matterhorn/Types/KeyEvents.hs @@ -111,6 +111,7 @@ | ViewMessageEvent | FillGapEvent + | CopyPostLinkEvent | FlagMessageEvent | PinMessageEvent | YankMessageEvent @@ -231,6 +232,7 @@ , PinMessageEvent , ViewMessageEvent , FillGapEvent + , CopyPostLinkEvent , YankMessageEvent , YankWholeMessageEvent , DeleteMessageEvent @@ -472,6 +474,7 @@ PinMessageEvent -> "pin-message" ViewMessageEvent -> "view-message" FillGapEvent -> "fetch-for-gap" + CopyPostLinkEvent -> "copy-post-link" YankMessageEvent -> "yank-message" YankWholeMessageEvent -> "yank-whole-message" DeleteMessageEvent -> "delete-message" diff --git a/src/Matterhorn/Types/RichText.hs b/src/Matterhorn/Types/RichText.hs --- a/src/Matterhorn/Types/RichText.hs +++ b/src/Matterhorn/Types/RichText.hs @@ -36,6 +36,7 @@ , findUsernames , blockGetURLs , findVerbatimChunk + , makePermalink ) where @@ -360,6 +361,10 @@ Right bs -> case mBaseUrl of Nothing -> bs Just baseUrl -> rewriteBlocksPermalinks baseUrl bs + +makePermalink :: TeamBaseURL -> PostId -> Text +makePermalink (TeamBaseURL (TeamURLName tName) (ServerBaseURL baseUrl)) pId = + baseUrl <> tName <> "/pl/" <> unId (unPI pId) -- | If the specified URL matches the active server base URL and team -- and refers to a post, extract the team name and post ID values and