matterhorn 50200.14.1 → 50200.15.0

raw patch · 25 files changed

+226/−172 lines, 25 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−0
• docs/keybindings.md +1/−0
• matterhorn.cabal +1/−2
• programs/Main.hs +3/−3
• src/Matterhorn/Draw/Main.hs +8/−2
• src/Matterhorn/Draw/ManageAttachments.hs +6/−5
• src/Matterhorn/Draw/NotifyPrefs.hs +2/−2
• src/Matterhorn/Draw/ShowHelp.hs +3/−2
• src/Matterhorn/Draw/TabbedWindow.hs +4/−4
• src/Matterhorn/Draw/ThemeListOverlay.hs +3/−2
• src/Matterhorn/Draw/Util.hs +5/−4
• src/Matterhorn/Events/Keybindings.hs +21/−10
• src/Matterhorn/Events/MessageSelect.hs +3/−0
• src/Matterhorn/KeyMap.hs +0/−28
• src/Matterhorn/Login.hs +4/−1
• src/Matterhorn/Options.hs +2/−2
• src/Matterhorn/State/Common.hs +59/−55
• src/Matterhorn/State/Links.hs +14/−4
• src/Matterhorn/State/MessageSelect.hs +15/−6
• src/Matterhorn/State/Messages.hs +26/−25
• src/Matterhorn/State/Setup/Threads.hs +14/−8
• src/Matterhorn/State/UrlSelect.hs +4/−7
• src/Matterhorn/Types.hs +1/−0
• src/Matterhorn/Types/KeyEvents.hs +3/−0
• src/Matterhorn/Types/RichText.hs +5/−0

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -917,6 +917,7 @@     | ResolveError HostNotResolved     | AuthIOError IOError     | LoginError LoginFailureException+    | MattermostServerError MattermostError     | OtherAuthError SomeException     deriving (Show) 

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

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