diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,31 @@ +90000.0.0 +========= + +NOTE: this version of Matterhorn requires server version 9.0 or greater. + +Package changes: +* Updated to use Vty 6 for crossplatform terminal support, meaning + Matterhorn can now be built and run on Windows terminals. Please let + us know if you try this and encounter any issues! + +Enhancements: +* Added support for a new "auto" mode to determine channel list width. + There is now a new `auto` value for the `channelListWidth` + configuration file setting. Its default is unchanged and it can still + take an integer value specifying the channel list width in columns. + If set to `auto`, its value is determined by Matterhorn, bounded by + minimum and maximum values, as a function of window width. This is + intended to give nicer results as font size decreases, up to a point. +* Add a `/write-theme` command to write the current theme to an INI + file. + +Bug fixes: +* Updated channel viewing book-keeping to work with changes in + Mattermost 9.0. +* Fixed an issue where terminal input provided right before the UI is + initialized could cause the application to crash. + 50200.19.0 ========== diff --git a/docs/commands.md b/docs/commands.md --- a/docs/commands.md +++ b/docs/commands.md @@ -58,3 +58,4 @@ | `/topic ` | Set the current channel's topic (header) | | `/user` | Show users to initiate a private DM chat channel | | `/username-attribute <@user>` | Display the attribute used to color the specified username | +| `/write-theme ` | Write the current theme to a theme settings file | diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 50200.19.0 +version: 90000.0.0 synopsis: Terminal client for the Mattermost chat system description: This is a terminal client for the Mattermost chat system. Please see the README for a list of @@ -170,31 +170,32 @@ ghc-options: -fhide-source-paths build-depends: base >=4.8 && <5 - , mattermost-api == 50200.15.0 + , mattermost-api == 90000.0.0 , base-compat >= 0.9 && < 0.13 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.7 , split >= 0.2 && < 0.3 , data-clist >= 0.1.2 && < 0.2 , semigroups >= 0.18 && < 0.20 - , connection >= 0.2 && < 0.4 - , text >= 1.2.5.0 && < 2.0 + , crypton-connection >= 0.3.1 && < 0.4 + , text >= 1.2.5.0 && < 2.1 , bytestring >= 0.10 && < 0.12 , stm >= 2.4 && < 2.6 , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.5 - , brick >= 1.8 && < 1.9 + , brick >= 2.0 && < 2.1 , brick-skylighting >= 1.0 && < 1.1 - , vty >= 5.38 && < 5.39 + , vty >= 6.0 && < 6.1 + , vty-crossplatform >= 0.2.0.0 && < 0.3.0.0 , word-wrap >= 0.4.0 && < 0.5 - , transformers >= 0.4 && < 0.6 + , transformers >= 0.4 && < 0.7 , text-zipper >= 0.13 && < 0.14 , time >= 1.6 && < 2.0 , xdg-basedir >= 0.2 && < 0.3 , filepath >= 1.4 && < 1.5 , directory >= 1.3 && < 1.4 - , vector < 0.13 + , vector < 0.14 , strict >= 0.3 && < 0.6 , hashable >= 1.2 && < 1.5 , commonmark >= 0.2.1 && < 0.3 @@ -207,7 +208,7 @@ , mtl >= 2.2 && < 2.4 , aspell-pipe >= 0.6 && < 0.7 , stm-delay >= 0.1 && < 0.2 - , unix >= 2.7.1.0 && < 2.9 + , unix-compat >= 0.6 && < 0.8 , skylighting-core >= 0.12 && < 0.13 , timezone-olson >= 0.2 && < 0.3 , timezone-series >= 0.1.6.1 && < 0.2 diff --git a/src/Matterhorn/App.hs b/src/Matterhorn/App.hs --- a/src/Matterhorn/App.hs +++ b/src/Matterhorn/App.hs @@ -10,9 +10,9 @@ import Brick import Control.Monad.Trans.Except ( runExceptT ) import qualified Graphics.Vty as Vty +import qualified Graphics.Vty.CrossPlatform as Vty import Text.Aspell ( stopAspell ) import GHC.Conc (getNumProcessors, setNumCapabilities) -import System.Posix.IO ( stdInput ) import Network.Mattermost @@ -32,11 +32,14 @@ app = App { appDraw = draw , appHandleEvent = Events.onEvent - , appStartEvent = return () , appAttrMap = (^.csResources.crTheme) , appChooseCursor = \s cs -> do tId <- s^.csCurrentTeamId cursorByMode cs s tId (teamMode $ s^.csTeam(tId)) + , appStartEvent = do + vty <- getVtyHandle + (w, h) <- liftIO $ Vty.displayBounds $ Vty.outputIface vty + runMHEvent $ Events.setWindowSize w h } cursorByMode :: [CursorLocation Name] -> ChatState -> TeamId -> Mode -> Maybe (CursorLocation Name) @@ -84,12 +87,7 @@ setupCpuUsage config let mkVty = do - mEraseChar <- Vty.getTtyEraseChar stdInput - let addEraseChar cfg = case mEraseChar of - Nothing -> cfg - Just ch -> cfg { Vty.inputMap = (Nothing, [ch], Vty.EvKey Vty.KBS []) : Vty.inputMap cfg } - - vty <- Vty.mkVty $ addEraseChar Vty.defaultConfig + vty <- Vty.mkVty Vty.defaultConfig let output = Vty.outputIface vty Vty.setMode output Vty.BracketedPaste True Vty.setMode output Vty.Hyperlink $ configHyperlinkingMode config diff --git a/src/Matterhorn/Command.hs b/src/Matterhorn/Command.hs --- a/src/Matterhorn/Command.hs +++ b/src/Matterhorn/Command.hs @@ -12,6 +12,7 @@ import Matterhorn.Prelude import Brick.Main ( invalidateCache ) +import Brick.Themes ( saveTheme ) import qualified Control.Exception as Exn import qualified Data.Char as Char import qualified Data.Text as T @@ -132,6 +133,12 @@ , Cmd "members" "Show the current channel's members" NoArg $ \ () -> do withCurrentTeam enterChannelMembersUserList + + , Cmd "write-theme" "Write the current theme to a theme settings file" + (TokenArg "path" NoArg) $ \(path, ()) -> do + theme <- use (csResources.crThemeOriginal) + liftIO $ saveTheme (T.unpack path) theme + postInfoMessage $ "Current theme written to " <> path , Cmd "leave" "Leave a normal channel or hide a DM channel" NoArg $ \ () -> do withCurrentTeam startLeaveCurrentChannel diff --git a/src/Matterhorn/Config.hs b/src/Matterhorn/Config.hs --- a/src/Matterhorn/Config.hs +++ b/src/Matterhorn/Config.hs @@ -80,7 +80,7 @@ configTeam <- fieldMbOf "team" stringField configPort <- fieldDefOf "port" number (configPort defaultConfig) configUrlPath <- fieldMbOf "urlPath" stringField - configChannelListWidth <- fieldDefOf "channelListWidth" number + configChannelListWidth <- fieldDefOf "channelListWidth" channelListWidthField (configChannelListWidth defaultConfig) configCpuUsagePolicy <- fieldDefOf "cpuUsagePolicy" cpuUsagePolicy (configCpuUsagePolicy defaultConfig) @@ -260,6 +260,14 @@ , (MoveCurrentTeamRightEvent , [ ]) ] +channelListWidthField :: Text -> Either String ChannelListWidth +channelListWidthField t = + case T.toLower t of + "auto" -> return ChannelListWidthAuto + _ -> case readMaybe (T.unpack t) of + Nothing -> Left "Invalid value for channelListWidth" + Just w -> Right $ ChannelListWidthFixed w + channelListOrientationField :: Text -> Either String ChannelListOrientation channelListOrientationField t = case T.toLower t of @@ -416,7 +424,7 @@ , configAspellDictionary = Nothing , configUnsafeUseHTTP = False , configValidateServerCertificate = True - , configChannelListWidth = 22 + , configChannelListWidth = ChannelListWidthFixed 22 , configLogMaxBufferSize = 200 , configShowOlderEdits = True , configUserKeys = newKeyConfig allEvents [] [] diff --git a/src/Matterhorn/Constants.hs b/src/Matterhorn/Constants.hs --- a/src/Matterhorn/Constants.hs +++ b/src/Matterhorn/Constants.hs @@ -8,6 +8,8 @@ , userSigil , userSigilChar , editMarking + , channelListMinAutoWidth + , channelListMaxAutoWidth ) where @@ -16,6 +18,14 @@ import qualified Data.Text as T + +-- | The minimum channel list width when the width is set to 'auto'. +channelListMinAutoWidth :: Int +channelListMinAutoWidth = 24 + +-- | The maximum channel list width when the width is set to 'auto'. +channelListMaxAutoWidth :: Int +channelListMaxAutoWidth = 44 -- | The number of rows to consider a "page" when scrolling pageAmount :: Int diff --git a/src/Matterhorn/Draw/Autocomplete.hs b/src/Matterhorn/Draw/Autocomplete.hs --- a/src/Matterhorn/Draw/Autocomplete.hs +++ b/src/Matterhorn/Draw/Autocomplete.hs @@ -18,6 +18,7 @@ import Network.Mattermost.Types ( User(..), Channel(..), TeamId ) import Matterhorn.Constants ( normalChannelSigil ) +import Matterhorn.Draw.ChannelList ( channelListWidth ) import Matterhorn.Draw.Util ( mkChannelName ) import Matterhorn.Themes import Matterhorn.Types @@ -93,10 +94,9 @@ curUser = myUsername st cfg = st^.csResources.crConfiguration showingChanList = configShowChannelList cfg - chanListWidth = configChannelListWidth cfg maybeLimit = fromMaybe id $ do let sub = if showingChanList - then chanListWidth + 1 + then channelListWidth st + 1 else 0 threadNarrow = threadShowing && (cfg^.configThreadOrientationL `elem` [ThreadLeft, ThreadRight]) threadShowing = isJust $ st^.csTeam(tId).tsThreadInterface diff --git a/src/Matterhorn/Draw/ChannelList.hs b/src/Matterhorn/Draw/ChannelList.hs --- a/src/Matterhorn/Draw/ChannelList.hs +++ b/src/Matterhorn/Draw/ChannelList.hs @@ -16,7 +16,12 @@ -- channels matching the entered text (and highlighting the -- matching portion). -module Matterhorn.Draw.ChannelList (renderChannelList, renderChannelListHeader) where +module Matterhorn.Draw.ChannelList + ( renderChannelList + , renderChannelListHeader + , channelListWidth + ) +where import Prelude () import Matterhorn.Prelude @@ -34,6 +39,7 @@ import Matterhorn.Draw.Util import Matterhorn.State.Channels +import Matterhorn.Constants ( channelListMinAutoWidth, channelListMaxAutoWidth ) import Matterhorn.Themes import Matterhorn.Types import Matterhorn.Types.Common ( sanitizeUserText ) @@ -54,10 +60,17 @@ , entryUserStatus :: Maybe UserStatus } -sbRenderer :: ScrollbarRenderer n +sbRenderer :: VScrollbarRenderer n sbRenderer = - verticalScrollbarRenderer { renderScrollbarHandleBefore = str "▲" - , renderScrollbarHandleAfter = str "▼" + verticalScrollbarRenderer { renderVScrollbarHandleBefore = str "▲" + , renderVScrollbarHandleAfter = str "▼" + , scrollbarWidthAllocation = 2 + , renderVScrollbar = + hLimit 1 $ + renderVScrollbar verticalScrollbarRenderer + , renderVScrollbarTrough = + hLimit 1 $ + renderVScrollbarTrough verticalScrollbarRenderer } renderChannelListHeader :: ChatState -> MM.TeamId -> Widget Name @@ -84,9 +97,9 @@ renderChannelList st tId = header <=> vpBody where - (sbOrientation, sbPad) = case st^.csResources.crConfiguration.configChannelListOrientationL of - ChannelListLeft -> (OnLeft, padLeft (Pad 1)) - ChannelListRight -> (OnRight, padRight (Pad 1)) + sbOrientation = case st^.csResources.crConfiguration.configChannelListOrientationL of + ChannelListLeft -> OnLeft + ChannelListRight -> OnRight myUsername_ = myUsername st channelName e = ClickableChannelListEntry $ channelListEntryChannelId e renderEntry s e = clickable (channelName e) $ @@ -96,7 +109,7 @@ withVScrollBars sbOrientation $ withVScrollBarHandles $ withClickableVScrollBars VScrollBar $ - viewport (ChannelListViewport tId) Vertical $ sbPad body + viewport (ChannelListViewport tId) Vertical body body = case teamMode $ st^.csTeam(tId) of ChannelSelect -> let zipper = st^.csTeam(tId).tsChannelSelectState.channelSelectMatches @@ -269,3 +282,16 @@ returnChannelSigil :: String returnChannelSigil = "~" + +channelListWidthAutoPercent :: Double +channelListWidthAutoPercent = 0.2 + +channelListWidth :: ChatState -> Int +channelListWidth st = + case configChannelListWidth $ st^.csResources.crConfiguration of + ChannelListWidthFixed w -> w + ChannelListWidthAuto -> + let calcWidth = round $ channelListWidthAutoPercent * (fromIntegral width :: Double) + width = fst $ st^.csResources.crWindowSize + in min channelListMaxAutoWidth $ + max channelListMinAutoWidth calcWidth 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 @@ -20,7 +20,7 @@ ) -import Matterhorn.Draw.ChannelList ( renderChannelList ) +import Matterhorn.Draw.ChannelList ( renderChannelList, channelListWidth ) import Matterhorn.Draw.Messages import Matterhorn.Draw.MessageInterface import Matterhorn.Draw.Autocomplete @@ -76,10 +76,9 @@ mainDisplay = maybeSubdue messageInterface channelList = channelListMaybeVlimit mode $ - hLimit channelListWidth $ case mtId of + hLimit (channelListWidth st) $ case mtId of Nothing -> fill ' ' Just tId -> renderChannelList st tId - channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration channelListMaybeVlimit ChannelSelect w = Widget (hSize w) (vSize w) $ do ctx <- getContext diff --git a/src/Matterhorn/Events.hs b/src/Matterhorn/Events.hs --- a/src/Matterhorn/Events.hs +++ b/src/Matterhorn/Events.hs @@ -1,5 +1,6 @@ module Matterhorn.Events ( onEvent + , setWindowSize ) where @@ -194,20 +195,25 @@ ] handleResizeEvent :: Vty.Event -> MH Bool -handleResizeEvent (Vty.EvResize _ _) = do +handleResizeEvent (Vty.EvResize w h) = do + setWindowSize w h + return True +handleResizeEvent _ = + return False + +setWindowSize :: Int -> Int -> MH () +setWindowSize w h = do -- On resize, invalidate the entire rendering cache since many -- things depend on the window size. -- -- Note: we fall through after this because it is sometimes -- important for modes to have their own additional logic to run -- when a resize occurs, so we don't want to stop processing here. + csResources.crWindowSize .= (w, h) + mh invalidateCache withCurrentTeam $ \tId -> mh $ makeVisible $ SelectedChannelListEntry tId - - return True -handleResizeEvent _ = - return False handleTeamModeEvent :: Vty.Event -> MH Bool handleTeamModeEvent e = do diff --git a/src/Matterhorn/Events/Websocket.hs b/src/Matterhorn/Events/Websocket.hs --- a/src/Matterhorn/Events/Websocket.hs +++ b/src/Matterhorn/Events/Websocket.hs @@ -166,8 +166,14 @@ | otherwise -> return () WMChannelViewed - | Just cId <- wepChannelId $ weData we -> refreshChannelById cId + | Just cId <- wepChannelId $ weData we -> mhLog LogGeneral "WMChannelViewed received" >> refreshChannelById cId | otherwise -> return () + + WMMultipleChannelsViewed -> + case wepChannelTimes $ weData we of + Nothing -> return () + Just m -> + forM_ (HM.keys m) refreshChannelById WMChannelUpdated | Just cId <- webChannelId $ weBroadcast we -> do diff --git a/src/Matterhorn/InputHistory.hs b/src/Matterhorn/InputHistory.hs --- a/src/Matterhorn/InputHistory.hs +++ b/src/Matterhorn/InputHistory.hs @@ -20,8 +20,8 @@ import System.Directory ( createDirectoryIfMissing ) import System.FilePath ( dropFileName ) import qualified System.IO.Strict as S -import qualified System.Posix.Files as P -import qualified System.Posix.Types as P +import qualified System.PosixCompat.Files as P +import qualified System.PosixCompat.Types as P import Network.Mattermost.Types ( ChannelId ) diff --git a/src/Matterhorn/LastRunState.hs b/src/Matterhorn/LastRunState.hs --- a/src/Matterhorn/LastRunState.hs +++ b/src/Matterhorn/LastRunState.hs @@ -23,8 +23,8 @@ import Lens.Micro.Platform ( makeLenses ) import System.Directory ( createDirectoryIfMissing ) import System.FilePath ( dropFileName ) -import qualified System.Posix.Files as P -import qualified System.Posix.Types as P +import qualified System.PosixCompat.Files as P +import qualified System.PosixCompat.Types as P import Network.Mattermost.Lenses import Network.Mattermost.Types diff --git a/src/Matterhorn/Login.hs b/src/Matterhorn/Login.hs --- a/src/Matterhorn/Login.hs +++ b/src/Matterhorn/Login.hs @@ -69,7 +69,7 @@ import Data.List (tails, inits) import System.IO.Error ( catchIOError ) import qualified Data.Text as T -import Graphics.Vty hiding (mkVty) +import Graphics.Vty import Lens.Micro.Platform ( (.~), (.=), Lens', makeLenses ) import qualified System.IO.Error as Err import Network.URI ( URI(..), URIAuth(..), parseURI ) diff --git a/src/Matterhorn/State/Channels.hs b/src/Matterhorn/State/Channels.hs --- a/src/Matterhorn/State/Channels.hs +++ b/src/Matterhorn/State/Channels.hs @@ -334,7 +334,7 @@ -- Create a new ClientChannel structure cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$> - makeClientChannel eventQueue spellChecker (me^.userIdL) (channelTeamId nc) nc + makeClientChannel eventQueue spellChecker (me^.userIdL) (channelTeamId nc) nc member st <- use id @@ -506,8 +506,6 @@ postChangeChannelCommon :: TeamId -> MH () postChangeChannelCommon tId = do - -- resetEditorState cId - -- loadLastEdit tId fetchVisibleIfNeeded tId loadLastChannelInput :: Lens' ChatState (MessageInterface n i) -> MH () @@ -524,6 +522,7 @@ preChangeChannelCommon tId = do withCurrentChannel tId $ \cId _ -> do csTeam(tId).tsRecentChannel .= Just cId + csChannel(cId) %= clearEditedThreshold saveEditorInput :: Lens' ChatState (MessageInterface n i) -> MH () saveEditorInput which = 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 @@ -34,7 +34,7 @@ import qualified Data.Sequence as Seq import qualified Data.Text as T import Graphics.Vty ( outputIface ) -import Graphics.Vty.Output.Interface ( ringTerminalBell ) +import Graphics.Vty.Output ( ringTerminalBell ) import Lens.Micro.Platform ( Traversal', (.=), (%=), (%~), (.~) , to, at, traversed, filtered, ix, _1, _Just ) @@ -45,6 +45,7 @@ import Matterhorn.Constants import Matterhorn.State.Channels +import Matterhorn.State.ChannelList ( updateSidebar ) import Matterhorn.State.Common import Matterhorn.State.ThreadWindow import Matterhorn.State.MessageSelect @@ -579,6 +580,34 @@ not (userPrefs^.userPrefShowJoinLeave) && isJoinOrLeave cId = postChannelId new + -- TODO: match server-side logic to determine whether + -- this message counts as a post, for post-counting + -- purposes, to decide whether this should trigger an + -- increment of the total/viewed post counts + maybeIncrementTotalMessageCount = + let shouldIncrement = case newPostData of + RecentPost {} -> + True + _ -> + False + in if shouldIncrement + then incrementTotalMessageCount + else id + + maybeIncrementViewedMessageCount currCId = + let shouldIncrement = case newPostData of + RecentPost {} -> + currCId == Just cId + _ -> + False + in if shouldIncrement + then incrementViewedMessageCount + else id + + maybeIncrementMessageCounts currCId = + maybeIncrementTotalMessageCount . + maybeIncrementViewedMessageCount currCId + doAddMessage = do -- Do we have the user data for the post author? case cp^.cpUser of @@ -606,6 +635,7 @@ csChannels %= modifyChannelById cId ((ccMessageInterface.miMessages %~ addMessage msg') . (if not ignoredJoinLeaveMessage then adjustUpdated new else id) . + maybeIncrementMessageCounts currCId . (\c -> if currCId == Just cId then c else case newPostData of @@ -627,6 +657,8 @@ -- channel, the currently-selected team (mcurTId) -- since all DM channels appear in all teams. addPostToOpenThread (mTId <|> mcurTId) new msg' + + updateSidebar mTId postedChanMessage diff --git a/src/Matterhorn/State/Setup.hs b/src/Matterhorn/State/Setup.hs --- a/src/Matterhorn/State/Setup.hs +++ b/src/Matterhorn/State/Setup.hs @@ -161,6 +161,7 @@ , _crSubprocessLog = slc , _crWebsocketActionChan = wac , _crTheme = themeToAttrMap custTheme + , _crThemeOriginal = custTheme , _crStatusUpdateChan = userStatusChan , _crConfiguration = config , _crFlaggedPosts = mempty @@ -169,6 +170,7 @@ , _crLogManager = logMgr , _crEmoji = emoji , _crSpellChecker = spResult + , _crWindowSize = (0, 0) } st <- initializeState cr initialTeamId teams me diff --git a/src/Matterhorn/State/Teams.hs b/src/Matterhorn/State/Teams.hs --- a/src/Matterhorn/State/Teams.hs +++ b/src/Matterhorn/State/Teams.hs @@ -43,6 +43,10 @@ , teamOrderPref, Post, ChannelId, postId , emptyChannelNotifyProps, UserId , channelName, Type(..), channelDisplayName + , Channel, ChannelMember + , channelMemberMsgCount + , channelTotalMsgCount + , UserParam(UserById) ) import qualified Network.Mattermost.Endpoints as MM @@ -216,7 +220,8 @@ -- Since the only channel we are dealing with is by construction the -- last channel, we don't have to consider other cases here: chanPairs <- forM (toList chans) $ \c -> do - cChannel <- makeClientChannel eventQueue (cr^.crSpellChecker) (userId me) (Just tId) c + m <- MM.mmGetChannelMember (getId c) (UserById $ userId me) session + cChannel <- makeClientChannel eventQueue (cr^.crSpellChecker) (userId me) (Just tId) c m return (getId c, cChannel) now <- getCurrentTime @@ -434,16 +439,17 @@ -> UserId -> Maybe TeamId -> Channel + -> ChannelMember -> m ClientChannel -makeClientChannel eventQueue spellChecker myId tId nc = do +makeClientChannel eventQueue spellChecker myId tId nc member = do msgs <- emptyChannelMessages mi <- liftIO $ newChannelMessageInterface spellChecker eventQueue tId (getId nc) msgs - return ClientChannel { _ccInfo = initialChannelInfo myId nc + return ClientChannel { _ccInfo = initialChannelInfo myId nc member , _ccMessageInterface = mi } -initialChannelInfo :: UserId -> Channel -> ChannelInfo -initialChannelInfo myId chan = +initialChannelInfo :: UserId -> Channel -> ChannelMember -> ChannelInfo +initialChannelInfo myId chan member = let updated = chan ^. channelLastPostAtL in ChannelInfo { _cdChannelId = chan^.channelIdL , _cdTeamId = chan^.channelTeamIdL @@ -464,4 +470,6 @@ else Nothing , _cdSidebarShowOverride = Nothing , _cdFetchPending = False + , _cdTotalMessageCount = channelTotalMsgCount chan + , _cdViewedMessageCount = channelMemberMsgCount member } diff --git a/src/Matterhorn/State/Teams.hs-boot b/src/Matterhorn/State/Teams.hs-boot --- a/src/Matterhorn/State/Teams.hs-boot +++ b/src/Matterhorn/State/Teams.hs-boot @@ -6,9 +6,9 @@ import qualified Brick.BChan as BCH import Text.Aspell ( Aspell ) -import Network.Mattermost.Types ( Channel, UserId, TeamId ) +import Network.Mattermost.Types ( Channel, ChannelMember, UserId, TeamId ) import Matterhorn.Types ( MHEvent ) import Matterhorn.Types.Channels ( ClientChannel ) -makeClientChannel :: (MonadIO m) => BCH.BChan MHEvent -> Maybe Aspell -> UserId -> Maybe TeamId -> Channel -> m ClientChannel +makeClientChannel :: (MonadIO m) => BCH.BChan MHEvent -> Maybe Aspell -> UserId -> Maybe TeamId -> Channel -> ChannelMember -> m ClientChannel diff --git a/src/Matterhorn/State/ThemeListWindow.hs b/src/Matterhorn/State/ThemeListWindow.hs --- a/src/Matterhorn/State/ThemeListWindow.hs +++ b/src/Matterhorn/State/ThemeListWindow.hs @@ -85,3 +85,4 @@ Just it -> do mh invalidateCache csResources.crTheme .= (themeToAttrMap $ internalTheme it) + csResources.crThemeOriginal .= internalTheme it diff --git a/src/Matterhorn/Types.hs b/src/Matterhorn/Types.hs --- a/src/Matterhorn/Types.hs +++ b/src/Matterhorn/Types.hs @@ -99,6 +99,7 @@ , unsafeKeyDispatcher , bindingConflictMessage + , ChannelListWidth(..) , NotificationVersion(..) , PasswordSource(..) , TokenSource(..) @@ -235,6 +236,7 @@ , crUserPreferences , crEventQueue , crTheme + , crThemeOriginal , crStatusUpdateChan , crSubprocessLog , crWebsocketActionChan @@ -246,6 +248,7 @@ , crSyntaxMap , crLogManager , crSpellChecker + , crWindowSize , crEmoji , getSession , getResourceSession @@ -485,6 +488,14 @@ | TeamListSortUnreadFirst deriving (Eq, Show, Ord) +data ChannelListWidth = + ChannelListWidthFixed Int + -- ^ A fixed width in columns. + | ChannelListWidthAuto + -- ^ Automatically determine a reasonable width based on the window + -- dimensions. + deriving (Eq, Show, Ord) + -- | This is how we represent the user's configuration. Most fields -- correspond to configuration file settings (see Config.hs) but some -- are for internal book-keeping purposes only. @@ -549,7 +560,7 @@ -- ^ Whether to permit an insecure HTTP connection. , configValidateServerCertificate :: Bool -- ^ Whether to validate TLS certificates. - , configChannelListWidth :: Int + , configChannelListWidth :: ChannelListWidth -- ^ The width, in columns, of the channel list sidebar. , configLogMaxBufferSize :: Int -- ^ The maximum size, in log entries, of the internal log @@ -629,14 +640,18 @@ , _userPrefTeamOrder :: Maybe [TeamId] } -hasUnread' :: ClientChannel -> Bool -hasUnread' chan = fromMaybe False $ do +hasUnread :: ClientChannel -> Type -> Bool +hasUnread chan ty = let info = _ccInfo chan - lastViewTime <- _cdViewed info - return $ _cdMentionCount info > 0 || - (not (isMuted chan) && - (((_cdUpdated info) > lastViewTime) || - (isJust $ _cdEditedMessageThreshold info))) + hasMentions = countMentions && _cdMentionCount info > 0 + hasNewMessages = _cdTotalMessageCount info > _cdViewedMessageCount info + hasEditThreshold = isJust $ _cdEditedMessageThreshold info + countMentions = case ty of + Direct -> False + Group -> False + _ -> True + in hasMentions || + (not (isMuted chan) && (hasNewMessages || hasEditThreshold)) mkChannelZipperList :: ChannelListSorting -> UTCTime @@ -701,7 +716,7 @@ mkEntry (cId, ch) = ChannelListEntry { channelListEntryChannelId = cId , channelListEntryType = CLChannel , channelListEntryMuted = isMuted ch - , channelListEntryUnread = hasUnread' ch + , channelListEntryUnread = hasUnread ch ty , channelListEntrySortValue = ch^.ccInfo.cdDisplayName.to T.toLower , channelListEntryFavorite = isFavorite prefs cId } @@ -759,7 +774,7 @@ in fmap (\(cId, ch) -> ChannelListEntry { channelListEntryChannelId = cId , channelListEntryType = CLGroupDM , channelListEntryMuted = isMuted ch - , channelListEntryUnread = hasUnread' ch + , channelListEntryUnread = hasUnread ch Group , channelListEntrySortValue = ch^.ccInfo.cdDisplayName , channelListEntryFavorite = isFavorite prefs cId }) $ @@ -785,7 +800,7 @@ then return (ChannelListEntry { channelListEntryChannelId = cId , channelListEntryType = CLUserDM uId , channelListEntryMuted = isMuted c - , channelListEntryUnread = hasUnread' c + , channelListEntryUnread = hasUnread c Direct , channelListEntrySortValue = displayNameForUser u cconfig prefs , channelListEntryFavorite = isFavorite prefs cId }) @@ -815,7 +830,7 @@ cId = c^.ccInfo.cdChannelId in if isFavorite prefs cId then True - else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) + else (if hasUnread c Direct || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) then True else case dmChannelShowPreference prefs uId of Just False -> False @@ -841,7 +856,7 @@ cId = c^.ccInfo.cdChannelId in if isFavorite prefs cId then True - else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) + else (if hasUnread c Group || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) then True else case groupChannelShowPreference prefs cId of Just False -> False @@ -1070,6 +1085,7 @@ , _crSubprocessLog :: STM.TChan ProgramOutput , _crWebsocketActionChan :: STM.TChan WebsocketAction , _crTheme :: AttrMap + , _crThemeOriginal :: Theme , _crStatusUpdateChan :: STM.TChan [UserId] , _crConfiguration :: Config , _crFlaggedPosts :: Set PostId @@ -1078,6 +1094,7 @@ , _crLogManager :: LogManager , _crEmoji :: EmojiCollection , _crSpellChecker :: Maybe Aspell + , _crWindowSize :: (Int, Int) } -- | The 'GlobalEditState' value contains state not specific to any diff --git a/src/Matterhorn/Types/Channels.hs b/src/Matterhorn/Types/Channels.hs --- a/src/Matterhorn/Types/Channels.hs +++ b/src/Matterhorn/Types/Channels.hs @@ -19,6 +19,7 @@ , cdName, cdDisplayName, cdHeader, cdPurpose, cdType , cdMentionCount, cdDMUserId, cdChannelId , cdSidebarShowOverride, cdNotifyProps, cdTeamId, cdFetchPending + , cdTotalMessageCount, cdViewedMessageCount -- * Managing ClientChannel collections , noChannels, addChannel, removeChannel, findChannelById, modifyChannelById , channelByIdL, maybeChannelByIdL @@ -33,6 +34,8 @@ , adjustUpdated , adjustEditedThreshold , updateNewMessageIndicator + , incrementTotalMessageCount + , incrementViewedMessageCount -- * Notification settings , notifyPreference , isMuted @@ -72,6 +75,7 @@ , WithDefault(..) , ServerTime , TeamId + , channelTotalMsgCount ) import Matterhorn.Types.Messages ( Messages, noMessages, addMessage @@ -121,6 +125,8 @@ , _cdPurpose = (sanitizeUserText $ chan^.channelPurposeL) , _cdType = (chan^.channelTypeL) , _cdMentionCount = chanMember^.to channelMemberMentionCount + , _cdTotalMessageCount = channelTotalMsgCount chan + , _cdViewedMessageCount = chanMember^.to channelMemberMsgCount , _cdNotifyProps = chanMember^.to channelMemberNotifyProps } @@ -174,6 +180,10 @@ -- whether to show the channel. , _cdFetchPending :: Bool -- ^ Whether a fetch in this channel is pending + , _cdTotalMessageCount :: Int + -- ^ Total message count + , _cdViewedMessageCount :: Int + -- ^ Viewed message count, for tracking unread status } -- ** Channel-related Lenses @@ -328,6 +338,14 @@ maxPostTimestamp :: Post -> ServerTime maxPostTimestamp m = max (m^.postDeleteAtL . non (m^.postUpdateAtL)) (m^.postCreateAtL) + +incrementTotalMessageCount :: ClientChannel -> ClientChannel +incrementTotalMessageCount = + ccInfo.cdTotalMessageCount %~ succ + +incrementViewedMessageCount :: ClientChannel -> ClientChannel +incrementViewedMessageCount = + ccInfo.cdViewedMessageCount %~ succ updateNewMessageIndicator :: Post -> ClientChannel -> ClientChannel updateNewMessageIndicator m =