{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} module Matterhorn.Types ( ConnectionStatus(..) , HelpTopic(..) , ProgramOutput(..) , MHEvent(..) , InternalEvent(..) , StartupStateInfo(..) , MHError(..) , CPUUsagePolicy(..) , SemEq(..) , handleEventWith , getServerBaseUrl , serverBaseUrl , ConnectionInfo(..) , SidebarUpdate(..) , PendingChannelChange(..) , ViewMessageWindowTab(..) , clearChannelUnreadStatus , ChannelListSorting(..) , TeamListSorting(..) , ThreadOrientation(..) , ChannelListOrientation(..) , channelListEntryUserId , userIdsFromZipper , entryIsDMEntry , ciHostname , ciPort , ciUrlPath , ciUsername , ciOTPToken , ciPassword , ciType , ciAccessToken , ChannelTopicDialogState(..) , channelTopicDialogEditor , channelTopicDialogFocus , resultToWidget , MHKeyEventHandler , mhHandleKeyboardEvent , Config(..) , configUserL , configHostL , configTeamL , configPortL , configUrlPathL , configPassL , configTokenL , configOTPTokenL , configTimeFormatL , configDateFormatL , configThemeL , configThemeCustomizationFileL , configSmartBacktickL , configSmartEditingL , configURLOpenCommandL , configURLOpenCommandInteractiveL , configActivityNotifyCommandL , configActivityNotifyVersionL , configActivityBellL , configTruncateVerbatimBlocksL , configChannelListSortingL , configTeamListSortingL , configShowMessageTimestampsL , configShowBackgroundL , configShowMessagePreviewL , configShowChannelListL , configShowExpandedChannelTopicsL , configEnableAspellL , configAspellDictionaryL , configUnsafeUseHTTPL , configValidateServerCertificateL , configChannelListWidthL , configLogMaxBufferSizeL , configShowOlderEditsL , configShowTypingIndicatorL , configSendTypingNotificationsL , configAbsPathL , configUserKeysL , configHyperlinkingModeL , configSyntaxDirsL , configDirectChannelExpirationDaysL , configCpuUsagePolicyL , configDefaultAttachmentPathL , configChannelListOrientationL , configThreadOrientationL , configMouseModeL , configShowLastOpenThreadL , unsafeKeyDispatcher , bindingConflictMessage , NotificationVersion(..) , PasswordSource(..) , TokenSource(..) , OTPTokenSource(..) , MatchType(..) , Mode(..) , ChannelSelectPattern(..) , PostListContents(..) , AuthenticationException(..) , BackgroundInfo(..) , RequestChan , UserFetch(..) , writeBChan , InternalTheme(..) , attrNameToConfig , matchesTeam , teamUnreadCount , teamZipperIds , mkChannelZipperList , ChannelListGroup(..) , nonDMChannelListGroupUnread , ThreadInterface , ChannelMessageInterface , threadInterface , unsafeThreadInterface , maybeThreadInterface , threadInterfaceEmpty , threadInterfaceDeleteWhere , modifyThreadMessages , modifyEachThreadMessage , trimChannelSigil , ChannelSelectState(..) , channelSelectMatches , channelSelectInput , emptyChannelSelectState , TeamState(..) , tsFocus , tsPendingChannelChange , tsRecentChannel , tsReturnChannel , tsTeam , tsChannelSelectState , tsViewedMessage , tsPostListWindow , tsUserListWindow , tsChannelListWindow , tsNotifyPrefs , tsChannelTopicDialog , tsReactionEmojiListWindow , tsThemeListWindow , tsChannelListSorting , tsThreadInterface , tsMessageInterfaceFocus , teamMode , teamModes , getTeamMode , MessageInterfaceFocus(..) , messageInterfaceFocusNext , messageInterfaceFocusPrev , channelEditor , channelMessageSelect , ChatState , newState , withCurrentChannel , withCurrentChannel' , withCurrentTeam , csTeamZipper , csTeams , csTeam , csChannelListOrientation , csResources , csLastMouseDownEvent , csGlobalEditState , csVerbatimTruncateSetting , csCurrentChannelId , csCurrentTeamId , csPostMap , csUsers , csHiddenChannelGroups , csConnectionStatus , csWorkerIsBusy , csChannel , csChannelMessages , csChannelMessageInterface , maybeChannelMessageInterface , csChannels , csClientConfig , csInputHistory , csMe , timeZone , whenMode , pushMode , pushMode' , popMode , replaceMode , GlobalEditState(..) , emptyGlobalEditState , gedYankBuffer , PostListWindowState(..) , postListSelected , postListPosts , UserSearchScope(..) , ChannelSearchScope(..) , ListWindowState(..) , listWindowSearchResults , listWindowSearchInput , listWindowSearchScope , listWindowSearching , listWindowEnterHandler , listWindowNewList , listWindowFetchResults , listWindowRecordCount , getUsers , ChatResources(..) , crUserPreferences , crEventQueue , crTheme , crStatusUpdateChan , crSubprocessLog , crWebsocketActionChan , crWebsocketThreadId , crRequestQueue , crFlaggedPosts , crConn , crConfiguration , crSyntaxMap , crLogManager , crSpellChecker , crEmoji , getSession , getResourceSession , specialUserMentions , applyTeamOrder , refreshTeamZipper , UserPreferences(UserPreferences) , userPrefShowJoinLeave , userPrefFlaggedPostList , userPrefGroupChannelPrefs , userPrefDirectChannelPrefs , userPrefTeammateNameDisplayMode , userPrefTeamOrder , userPrefFavoriteChannelPrefs , dmChannelShowPreference , groupChannelShowPreference , favoriteChannelPreference , defaultUserPreferences , setUserPreferences , WebsocketAction(..) , Cmd(..) , commandName , CmdArgs(..) , MH , runMHEvent , scheduleUserFetches , scheduleUserStatusFetches , getScheduledUserFetches , getScheduledUserStatusFetches , mh , generateUUID , generateUUID_IO , mhSuspendAndResume , mhZoom , mhZoom' , mhContinueWithoutRedraw , St.gets , mhError , mhLog , mhGetIOLogger , ioLogWithManager , LogContext(..) , withLogContext , withLogContextChannelId , getLogContext , LogMessage(..) , LogCommand(..) , LogCategory(..) , LogManager(..) , startLoggingToFile , stopLoggingToFile , requestLogSnapshot , requestLogDestination , sendLogMessage , requestQuit , getMessageForPostId , getParentMessage , getReplyRootMessage , withChannel , withChannelOrDefault , userList , resetAutocomplete , isMine , setUserStatus , myUser , myUsername , myUserId , usernameForUserId , userByUsername , userByNickname , channelIdByChannelName , channelIdByUsername , userById , allUserIds , addNewUser , useNickname , useNickname' , displayNameForUserId , displayNameForUser , raiseInternalEvent , getNewMessageCutoff , getEditedMessageCutoff , HighlightSet(..) , UserSet , ChannelSet , getHighlightSet , emptyHSet , moveLeft , moveRight , module Matterhorn.Types.Core , module Matterhorn.Types.Channels , module Matterhorn.Types.EditState , module Matterhorn.Types.Messages , module Matterhorn.Types.MessageInterface , module Matterhorn.Types.TabbedWindow , module Matterhorn.Types.Posts , module Matterhorn.Types.Users ) where import Prelude () import Matterhorn.Prelude import GHC.Stack ( HasCallStack ) import qualified Brick import Brick ( EventM, Widget(..), Size(..), Result ) import Brick.Keybindings import Brick.Focus ( FocusRing ) import Brick.Themes ( Theme ) import Brick.Main ( invalidateCache, invalidateCacheEntry ) import Brick.AttrMap ( AttrMap ) import qualified Brick.BChan as BCH import Brick.Forms (Form) import Brick.Widgets.Edit ( Editor, editor ) import Brick.Widgets.List ( List ) import Control.Concurrent ( ThreadId ) import Control.Concurrent.Async ( Async ) import qualified Control.Concurrent.STM as STM import Control.Exception ( SomeException ) import qualified Control.Monad.State as St import qualified Control.Monad.Reader as R import qualified Data.Set as Set import qualified Data.Foldable as F import Data.Function ( on ) import qualified Data.Kind as K import Data.Maybe ( fromJust ) import Data.Ord ( comparing, Down(..) ) import qualified Data.HashMap.Strict as HM import Data.List ( sortBy, elemIndex, partition ) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Time.Clock ( getCurrentTime, addUTCTime ) import Data.UUID ( UUID ) import qualified Data.Vector as Vec import qualified Graphics.Vty as Vty import Lens.Micro.Platform ( at, makeLenses, lens, (^?!), (.=) , (%=), (%~), (.~), _Just, Traversal', to , SimpleGetter, filtered, traversed, singular , zoom ) import Network.Connection ( HostNotResolved, HostCannotConnect ) import Skylighting.Types ( SyntaxMap ) import System.Exit ( ExitCode ) import System.Random ( randomIO ) import Text.Aspell ( Aspell ) import Network.Mattermost ( ConnectionData ) import Network.Mattermost.Exceptions import Network.Mattermost.Lenses import Network.Mattermost.Types import Network.Mattermost.Types.Config import Network.Mattermost.WebSocket ( WebsocketEvent, WebsocketActionResponse ) import Matterhorn.Constants ( normalChannelSigil ) import Matterhorn.InputHistory import Matterhorn.Emoji import Matterhorn.Types.Common import Matterhorn.Types.Core import Matterhorn.Types.Channels import Matterhorn.Types.EditState import Matterhorn.Types.Messages import Matterhorn.Types.MessageInterface import Matterhorn.Types.NonemptyStack import Matterhorn.Types.Posts import Matterhorn.Types.RichText ( TeamBaseURL(..), TeamURLName(..) ) import Matterhorn.Types.TabbedWindow import Matterhorn.Types.Users import qualified Matterhorn.Zipper as Z -- * Configuration -- | A notification version for the external notifier data NotificationVersion = NotifyV1 | NotifyV2 | NotifyV3 deriving (Eq, Read, Show) -- | A user password is either given to us directly, or a command -- which we execute to find the password. data PasswordSource = PasswordString Text | PasswordCommand Text deriving (Eq, Read, Show) -- | An access token source. data TokenSource = TokenString Text | TokenCommand Text deriving (Eq, Read, Show) -- | An OTP token source. data OTPTokenSource = OTPTokenString Text | OTPTokenCommand Text deriving (Eq, Read, Show) -- | The type of channel list group headings. Integer arguments indicate -- total number of channels in the group that have unread activity. data ChannelListGroup = ChannelListGroup { channelListGroupLabel :: ChannelListGroupLabel , channelListGroupUnread :: Int , channelListGroupCollapsed :: Bool , channelListGroupEntries :: Int } deriving (Eq, Show) nonDMChannelListGroupUnread :: ChannelListGroup -> Int nonDMChannelListGroupUnread g = case channelListGroupLabel g of ChannelGroupDirectMessages -> 0 _ -> channelListGroupUnread g data ChannelListSorting = ChannelListSortDefault | ChannelListSortUnreadFirst deriving (Eq, Show, Ord) data TeamListSorting = TeamListSortDefault | TeamListSortUnreadFirst 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. data Config = Config { configUser :: Maybe Text -- ^ The username to use when connecting. , configHost :: Maybe Text -- ^ The hostname to use when connecting. , configTeam :: Maybe Text -- ^ The team name to use when connecting. , configPort :: Int -- ^ The port to use when connecting. , configUrlPath :: Maybe Text -- ^ The server path to use when connecting. , configPass :: Maybe PasswordSource -- ^ The password source to use when connecting. , configToken :: Maybe TokenSource -- ^ The token source to use when connecting. , configOTPToken :: Maybe OTPTokenSource -- ^ The OTP token source to use when connecting. , configTimeFormat :: Maybe Text -- ^ The format string for timestamps. , configDateFormat :: Maybe Text -- ^ The format string for dates. , configTheme :: Maybe Text -- ^ The name of the theme to use. , configThemeCustomizationFile :: Maybe Text -- ^ The path to the theme customization file, if any. , configSmartBacktick :: Bool -- ^ Whether to enable smart quoting characters. , configSmartEditing :: Bool -- ^ Whether to enable smart editing behaviors. , configURLOpenCommand :: Maybe Text -- ^ The command to use to open URLs. , configURLOpenCommandInteractive :: Bool -- ^ Whether the URL-opening command is interactive (i.e. -- whether it should be given control of the terminal). , configActivityNotifyCommand :: Maybe T.Text -- ^ The command to run for activity notifications. , configActivityNotifyVersion :: NotificationVersion -- ^ The activity notifier version. , configActivityBell :: Bool -- ^ Whether to ring the terminal bell on activity. , configTruncateVerbatimBlocks :: Maybe Int -- ^ Whether to truncate verbatim (and code) blocks past a -- reasonable number of lines. , configShowMessageTimestamps :: Bool -- ^ Whether to show timestamps on messages. , configShowBackground :: BackgroundInfo -- ^ Whether to show async background worker thread info. , configShowMessagePreview :: Bool -- ^ Whether to show the message preview area. , configShowChannelList :: Bool -- ^ Whether to show the channel list. , configShowExpandedChannelTopics :: Bool -- ^ Whether to show expanded channel topics. , configEnableAspell :: Bool -- ^ Whether to enable Aspell spell checking. , configAspellDictionary :: Maybe Text -- ^ A specific Aspell dictionary name to use. , configUnsafeUseHTTP :: Bool -- ^ Whether to permit an insecure HTTP connection. , configValidateServerCertificate :: Bool -- ^ Whether to validate TLS certificates. , configChannelListWidth :: Int -- ^ The width, in columns, of the channel list sidebar. , configLogMaxBufferSize :: Int -- ^ The maximum size, in log entries, of the internal log -- message buffer. , configShowOlderEdits :: Bool -- ^ Whether to highlight the edit indicator on edits made -- prior to the beginning of the current session. , configChannelListSorting :: ChannelListSorting -- ^ How to sort channels in each channel list group , configTeamListSorting :: TeamListSorting -- ^ How to sort teams in the team list , configShowTypingIndicator :: Bool -- ^ Whether to show the typing indicator when other users -- are typing , configSendTypingNotifications :: Bool -- Whether to send typing notifications to other users. , configAbsPath :: Maybe FilePath -- ^ A book-keeping field for the absolute path to the -- configuration. (Not a user setting.) , configUserKeys :: KeyConfig KeyEvent -- ^ The user's keybinding configuration. , configHyperlinkingMode :: Bool -- ^ Whether to enable terminal hyperlinking mode. , configSyntaxDirs :: [FilePath] -- ^ The search path for syntax description XML files. , configDirectChannelExpirationDays :: Int -- ^ The number of days to show a user in the channel menu after a direct -- message with them. , configCpuUsagePolicy :: CPUUsagePolicy -- ^ The CPU usage policy for the application. , configDefaultAttachmentPath :: Maybe FilePath -- ^ The default path for browsing attachments , configChannelListOrientation :: ChannelListOrientation -- ^ The orientation of the channel list. , configThreadOrientation :: ThreadOrientation -- ^ The orientation of the thread window relative to the -- main channel message window. , configMouseMode :: Bool -- ^ Whether to enable mouse support in matterhorn , configShowLastOpenThread :: Bool -- ^ Whether to re-open a thread that was open the last time -- Matterhorn quit } deriving (Eq, Show) -- | The policy for CPU usage. -- -- The idea is that Matterhorn can benefit from using multiple CPUs, -- but the exact number is application-determined. We expose this policy -- setting to the user in the configuration. data CPUUsagePolicy = SingleCPU -- ^ Constrain the application to use one CPU. | MultipleCPUs -- ^ Permit the usage of multiple CPUs (the exact number is -- determined by the application). deriving (Eq, Show) -- | The state of the UI diagnostic indicator for the async worker -- thread. data BackgroundInfo = Disabled -- ^ Disable (do not show) the indicator. | Active -- ^ Show the indicator when the thread is working. | ActiveCount -- ^ Show the indicator when the thread is working, but include the -- thread's work queue length. deriving (Eq, Show) data UserPreferences = UserPreferences { _userPrefShowJoinLeave :: Bool , _userPrefFlaggedPostList :: Seq FlaggedPost , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool , _userPrefDirectChannelPrefs :: HashMap UserId Bool , _userPrefFavoriteChannelPrefs :: HashMap ChannelId Bool , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode , _userPrefTeamOrder :: Maybe [TeamId] } hasUnread' :: ClientChannel -> Bool hasUnread' chan = fromMaybe False $ do let info = _ccInfo chan lastViewTime <- _cdViewed info return $ _cdMentionCount info > 0 || (not (isMuted chan) && (((_cdUpdated info) > lastViewTime) || (isJust $ _cdEditedMessageThreshold info))) mkChannelZipperList :: ChannelListSorting -> UTCTime -> Config -> TeamId -> Maybe ClientConfig -> UserPreferences -> HM.HashMap TeamId (Set ChannelListGroupLabel) -> ClientChannels -> Users -> [(ChannelListGroup, [ChannelListEntry])] mkChannelZipperList sorting now config tId cconfig prefs hidden cs us = let (privFavs, privEntries) = partitionFavorites $ getChannelEntriesByType tId prefs cs Private (normFavs, normEntries) = partitionFavorites $ getChannelEntriesByType tId prefs cs Ordinary (dmFavs, dmEntries) = partitionFavorites $ getDMChannelEntries now config cconfig prefs us cs favEntries = privFavs <> normFavs <> dmFavs isHidden label = case HM.lookup tId hidden of Nothing -> False Just s -> Set.member label s in [ let unread = length $ filter channelListEntryUnread favEntries coll = isHidden ChannelGroupFavoriteChannels in ( ChannelListGroup ChannelGroupFavoriteChannels unread coll (length favEntries) , if coll then mempty else sortChannelListEntries sorting favEntries ) , let unread = length $ filter channelListEntryUnread normEntries coll = isHidden ChannelGroupPublicChannels in ( ChannelListGroup ChannelGroupPublicChannels unread coll (length normEntries) , if coll then mempty else sortChannelListEntries sorting normEntries ) , let unread = length $ filter channelListEntryUnread privEntries coll = isHidden ChannelGroupPrivateChannels in ( ChannelListGroup ChannelGroupPrivateChannels unread coll (length privEntries) , if coll then mempty else sortChannelListEntries sorting privEntries ) , let unread = length $ filter channelListEntryUnread dmEntries coll = isHidden ChannelGroupDirectMessages in ( ChannelListGroup ChannelGroupDirectMessages unread coll (length dmEntries) , if coll then mempty else sortDMChannelListEntries dmEntries ) ] sortChannelListEntries :: ChannelListSorting -> [ChannelListEntry] -> [ChannelListEntry] sortChannelListEntries ChannelListSortDefault = sortBy (comparing (\c -> (channelListEntryMuted c, channelListEntrySortValue c))) sortChannelListEntries ChannelListSortUnreadFirst = sortBy (comparing (not . channelListEntryUnread)) . sortChannelListEntries ChannelListSortDefault sortDMChannelListEntries :: [ChannelListEntry] -> [ChannelListEntry] sortDMChannelListEntries = sortBy compareDMChannelListEntries partitionFavorites :: [ChannelListEntry] -> ([ChannelListEntry], [ChannelListEntry]) partitionFavorites = partition channelListEntryFavorite getChannelEntriesByType :: TeamId -> UserPreferences -> ClientChannels -> Type -> [ChannelListEntry] getChannelEntriesByType tId prefs cs ty = let matches (_, info) = info^.ccInfo.cdType == ty && info^.ccInfo.cdTeamId == Just tId pairs = filteredChannels matches cs entries = mkEntry <$> pairs mkEntry (cId, ch) = ChannelListEntry { channelListEntryChannelId = cId , channelListEntryType = CLChannel , channelListEntryMuted = isMuted ch , channelListEntryUnread = hasUnread' ch , channelListEntrySortValue = ch^.ccInfo.cdDisplayName.to T.toLower , channelListEntryFavorite = isFavorite prefs cId } in entries getDMChannelEntries :: UTCTime -> Config -> Maybe ClientConfig -> UserPreferences -> Users -> ClientChannels -> [ChannelListEntry] getDMChannelEntries now config cconfig prefs us cs = let oneOnOneDmChans = getSingleDMChannelEntries now config cconfig prefs us cs groupChans = getGroupDMChannelEntries now config prefs cs in groupChans <> oneOnOneDmChans compareDMChannelListEntries :: ChannelListEntry -> ChannelListEntry -> Ordering compareDMChannelListEntries e1 e2 = let u1 = channelListEntryUnread e1 u2 = channelListEntryUnread e2 n1 = channelListEntrySortValue e1 n2 = channelListEntrySortValue e2 in if u1 == u2 then compare n1 n2 else if u1 && not u2 then LT else GT useNickname' :: Maybe ClientConfig -> UserPreferences -> Bool useNickname' clientConfig prefs = let serverSetting = case clientConfig^?_Just.to clientConfigTeammateNameDisplay of Just TMNicknameOrFullname -> Just True _ -> Nothing accountSetting = (== TMNicknameOrFullname) <$> (_userPrefTeammateNameDisplayMode prefs) fallback = False in fromMaybe fallback $ accountSetting <|> serverSetting displayNameForUser :: UserInfo -> Maybe ClientConfig -> UserPreferences -> Text displayNameForUser u clientConfig prefs | useNickname' clientConfig prefs = fromMaybe (u^.uiName) (u^.uiNickName) | otherwise = u^.uiName getGroupDMChannelEntries :: UTCTime -> Config -> UserPreferences -> ClientChannels -> [ChannelListEntry] getGroupDMChannelEntries now config prefs cs = let matches (_, info) = info^.ccInfo.cdType == Group && info^.ccInfo.cdTeamId == Nothing && groupChannelShouldAppear now config prefs info in fmap (\(cId, ch) -> ChannelListEntry { channelListEntryChannelId = cId , channelListEntryType = CLGroupDM , channelListEntryMuted = isMuted ch , channelListEntryUnread = hasUnread' ch , channelListEntrySortValue = ch^.ccInfo.cdDisplayName , channelListEntryFavorite = isFavorite prefs cId }) $ filteredChannels matches cs getSingleDMChannelEntries :: UTCTime -> Config -> Maybe ClientConfig -> UserPreferences -> Users -> ClientChannels -> [ChannelListEntry] getSingleDMChannelEntries now config cconfig prefs us cs = let mapping = allDmChannelMappings cs mappingWithUserInfo = catMaybes $ getInfo <$> mapping getInfo (uId, cId) = do c <- findChannelById cId cs u <- findUserById uId us case u^.uiDeleted of True -> Nothing False -> if dmChannelShouldAppear now config prefs c then return (ChannelListEntry { channelListEntryChannelId = cId , channelListEntryType = CLUserDM uId , channelListEntryMuted = isMuted c , channelListEntryUnread = hasUnread' c , channelListEntrySortValue = displayNameForUser u cconfig prefs , channelListEntryFavorite = isFavorite prefs cId }) else Nothing in mappingWithUserInfo -- | Return whether the specified channel has been marked as a favorite -- channel. isFavorite :: UserPreferences -> ChannelId -> Bool isFavorite prefs cId = favoriteChannelPreference prefs cId == Just True -- Always show a DM channel if it has unread activity or has been marked -- as a favorite. -- -- If it has no unread activity and if the preferences explicitly say to -- hide it, hide it. -- -- Otherwise, only show it if at least one of the other conditions are -- met (see 'or' below). dmChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool dmChannelShouldAppear now config prefs c = let ndays = configDirectChannelExpirationDays config localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now cutoff = ServerTime localCutoff updated = c^.ccInfo.cdUpdated uId = fromJust $ c^.ccInfo.cdDMUserId cId = c^.ccInfo.cdChannelId in if isFavorite prefs cId then True else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) then True else case dmChannelShowPreference prefs uId of Just False -> False _ -> or [ -- The channel was updated recently enough updated >= cutoff ]) -- Always show a group DM channel if it has unread activity or has been -- marked as a favorite. -- -- If it has no unread activity and if the preferences explicitly say to -- hide it, hide it. -- -- Otherwise, only show it if at least one of the other conditions are -- met (see 'or' below). groupChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool groupChannelShouldAppear now config prefs c = let ndays = configDirectChannelExpirationDays config localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now cutoff = ServerTime localCutoff updated = c^.ccInfo.cdUpdated cId = c^.ccInfo.cdChannelId in if isFavorite prefs cId then True else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) then True else case groupChannelShowPreference prefs cId of Just False -> False _ -> or [ -- The channel was updated recently enough updated >= cutoff ]) dmChannelShowPreference :: UserPreferences -> UserId -> Maybe Bool dmChannelShowPreference ps uId = HM.lookup uId (_userPrefDirectChannelPrefs ps) groupChannelShowPreference :: UserPreferences -> ChannelId -> Maybe Bool groupChannelShowPreference ps cId = HM.lookup cId (_userPrefGroupChannelPrefs ps) favoriteChannelPreference :: UserPreferences -> ChannelId -> Maybe Bool favoriteChannelPreference ps cId = HM.lookup cId (_userPrefFavoriteChannelPrefs ps) -- | Types that provide a "semantically equal" operation. Two values may -- be semantically equal even if they are not equal according to Eq if, -- for example, they are equal on the basis of some fields that are more -- pertinent than others. class (Show a, Eq a, Ord a) => SemEq a where semeq :: a -> a -> Bool instance SemEq Name where semeq (ClickableURL mId1 r1 _ t1) (ClickableURL mId2 r2 _ t2) = mId1 == mId2 && t1 == t2 && r1 == r2 semeq (ClickableUsername mId1 r1 _ n) (ClickableUsername mId2 r2 _ n2) = mId1 == mId2 && n == n2 && r1 == r2 semeq a b = a == b instance SemEq a => SemEq (Maybe a) where semeq Nothing Nothing = True semeq (Just a) (Just b) = a `semeq` b semeq _ _ = False -- | The sum type of exceptions we expect to encounter on authentication -- failure. We encode them explicitly here so that we can print them in -- a more user-friendly manner than just 'show'. data AuthenticationException = ConnectError HostCannotConnect | ResolveError HostNotResolved | AuthIOError IOError | LoginError LoginFailureException | MattermostServerError MattermostError | OtherAuthError SomeException deriving (Show) -- | Our 'ConnectionInfo' contains exactly as much information as is -- necessary to start a connection with a Mattermost server. This is -- built up during interactive authentication and then is used to log -- in. -- -- If the access token field is non-empty, that value is used and the -- username and password values are ignored. data ConnectionInfo = ConnectionInfo { _ciHostname :: Text , _ciPort :: Int , _ciUrlPath :: Text , _ciUsername :: Text , _ciOTPToken :: Maybe Text , _ciPassword :: Text , _ciAccessToken :: Text , _ciType :: ConnectionType } -- | We want to continue referring to posts by their IDs, but we don't -- want to have to synthesize new valid IDs for messages from the client -- itself (like error messages or informative client responses). To that -- end, a PostRef can be either a PostId or a newly-generated client ID. data PostRef = MMId PostId | CLId Int deriving (Eq, Show) -- ** Channel-matching types data ChannelSelectPattern = CSP MatchType Text | CSPAny deriving (Eq, Show) data MatchType = Prefix | Suffix | Infix | Equal | PrefixDMOnly | PrefixNonDMOnly deriving (Eq, Show) -- * Application State Values data ProgramOutput = ProgramOutput { program :: FilePath , programArgs :: [String] , programStdout :: String , programStderr :: String , programExitCode :: ExitCode } defaultUserPreferences :: UserPreferences defaultUserPreferences = UserPreferences { _userPrefShowJoinLeave = True , _userPrefFlaggedPostList = mempty , _userPrefGroupChannelPrefs = mempty , _userPrefDirectChannelPrefs = mempty , _userPrefFavoriteChannelPrefs = mempty , _userPrefTeammateNameDisplayMode = Nothing , _userPrefTeamOrder = Nothing } setUserPreferences :: Seq Preference -> UserPreferences -> UserPreferences setUserPreferences = flip (F.foldr go) where go p u | Just fp <- preferenceToFlaggedPost p = u { _userPrefFlaggedPostList = _userPrefFlaggedPostList u Seq.|> fp } | Just gp <- preferenceToDirectChannelShowStatus p = u { _userPrefDirectChannelPrefs = HM.insert (directChannelShowUserId gp) (directChannelShowValue gp) (_userPrefDirectChannelPrefs u) } | Just gp <- preferenceToGroupChannelPreference p = u { _userPrefGroupChannelPrefs = HM.insert (groupChannelId gp) (groupChannelShow gp) (_userPrefGroupChannelPrefs u) } | Just fp <- preferenceToFavoriteChannelPreference p = u { _userPrefFavoriteChannelPrefs = HM.insert (favoriteChannelId fp) (favoriteChannelShow fp) (_userPrefFavoriteChannelPrefs u) } | Just tIds <- preferenceToTeamOrder p = u { _userPrefTeamOrder = Just tIds } | preferenceName p == PreferenceName "join_leave" = u { _userPrefShowJoinLeave = preferenceValue p /= PreferenceValue "false" } | preferenceCategory p == PreferenceCategoryDisplaySettings && preferenceName p == PreferenceName "name_format" = let PreferenceValue txt = preferenceValue p in u { _userPrefTeammateNameDisplayMode = Just $ teammateDisplayModeFromText txt } | otherwise = u -- | Log message tags. data LogCategory = LogGeneral | LogAPI | LogWebsocket | LogError | LogUserMark deriving (Eq, Show) -- | A log message. data LogMessage = LogMessage { logMessageText :: !Text -- ^ The text of the log message. , logMessageContext :: !(Maybe LogContext) -- ^ The optional context information relevant to the log -- message. , logMessageCategory :: !LogCategory -- ^ The category of the log message. , logMessageTimestamp :: !UTCTime -- ^ The timestamp of the log message. } deriving (Eq, Show) -- | A logging thread command. data LogCommand = LogToFile FilePath -- ^ Start logging to the specified path. | LogAMessage !LogMessage -- ^ Log the specified message. | StopLogging -- ^ Stop any active logging. | ShutdownLogging -- ^ Shut down. | GetLogDestination -- ^ Ask the logging thread about its active logging destination. | LogSnapshot FilePath -- ^ Ask the logging thread to dump the current buffer to the -- specified destination. deriving (Show) -- | A handle to the log manager thread. data LogManager = LogManager { logManagerCommandChannel :: STM.TChan LogCommand , logManagerHandle :: Async () } startLoggingToFile :: LogManager -> FilePath -> IO () startLoggingToFile mgr loc = sendLogCommand mgr $ LogToFile loc stopLoggingToFile :: LogManager -> IO () stopLoggingToFile mgr = sendLogCommand mgr StopLogging requestLogSnapshot :: LogManager -> FilePath -> IO () requestLogSnapshot mgr path = sendLogCommand mgr $ LogSnapshot path requestLogDestination :: LogManager -> IO () requestLogDestination mgr = sendLogCommand mgr GetLogDestination sendLogMessage :: LogManager -> LogMessage -> IO () sendLogMessage mgr lm = sendLogCommand mgr $ LogAMessage lm sendLogCommand :: LogManager -> LogCommand -> IO () sendLogCommand mgr c = STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) c -- | 'ChatResources' represents configuration and connection-related -- information, as opposed to current model or view information. -- Information that goes in the 'ChatResources' value should be limited -- to information that we read or set up prior to setting up the bulk of -- the application state. data ChatResources = ChatResources { _crSession :: Session , _crWebsocketThreadId :: Maybe ThreadId , _crConn :: ConnectionData , _crRequestQueue :: RequestChan , _crEventQueue :: BCH.BChan MHEvent , _crSubprocessLog :: STM.TChan ProgramOutput , _crWebsocketActionChan :: STM.TChan WebsocketAction , _crTheme :: AttrMap , _crStatusUpdateChan :: STM.TChan [UserId] , _crConfiguration :: Config , _crFlaggedPosts :: Set PostId , _crUserPreferences :: UserPreferences , _crSyntaxMap :: SyntaxMap , _crLogManager :: LogManager , _crEmoji :: EmojiCollection , _crSpellChecker :: Maybe Aspell } -- | The 'GlobalEditState' value contains state not specific to any -- single editor. data GlobalEditState = GlobalEditState { _gedYankBuffer :: Text } emptyGlobalEditState :: GlobalEditState emptyGlobalEditState = GlobalEditState { _gedYankBuffer = "" } -- | A 'RequestChan' is a queue of operations we have to perform in the -- background to avoid blocking on the main loop type RequestChan = STM.TChan (IO (Maybe (MH ()))) -- | Help topics data HelpTopic = HelpTopic { helpTopicName :: Text , helpTopicDescription :: Text , helpTopicScreen :: HelpScreen } deriving (Eq, Show) -- | Mode type for the current contents of the post list window data PostListContents = PostListFlagged | PostListPinned ChannelId | PostListSearch Text Bool -- for the query and search status deriving (Eq, Show) -- | The 'Mode' represents the current dominant UI activity data Mode = Main | ShowHelp HelpTopic | ChannelSelect | LeaveChannelConfirm | DeleteChannelConfirm | MessageSelectDeleteConfirm MessageInterfaceTarget | PostListWindow PostListContents | UserListWindow | ReactionEmojiListWindow | ChannelListWindow | ThemeListWindow | ViewMessage | EditNotifyPrefs | ChannelTopicWindow deriving (Eq, Show) -- | We're either connected or we're not. data ConnectionStatus = Connected | Disconnected deriving (Eq) type ThreadInterface = MessageInterface Name PostId type ChannelMessageInterface = MessageInterface Name () data ChannelListOrientation = ChannelListLeft -- ^ Show the channel list to the left of the message area. | ChannelListRight -- ^ Show the channel list to the right of the message area. deriving (Eq, Show) data ThreadOrientation = ThreadBelow -- ^ Show the thread below the channel message area. | ThreadAbove -- ^ Show the thread above the channel message area. | ThreadLeft -- ^ Show the thread to the left of the channel message area. | ThreadRight -- ^ Show the thread to the right of the channel message area. deriving (Eq, Show) -- | This type represents the current state of our application at any -- given time. data ChatState = ChatState { _csResources :: ChatResources -- ^ Global application-wide resources that don't change -- much. , _csLastMouseDownEvent :: Maybe (Brick.BrickEvent Name MHEvent) -- ^ The most recent mouse click event we got. We reset -- this on mouse up so we can ignore clicks whenever this -- is already set. , _csVerbatimTruncateSetting :: Maybe Int -- ^ The current verbatim block truncation setting. This -- is used to toggle truncation behavior and is updated -- from the configTruncateVerbatimBlocks Config field. , _csTeams :: HashMap TeamId TeamState -- ^ The state for each team that we are in. , _csTeamZipper :: Z.Zipper () TeamId -- ^ The list of teams we can cycle through. , _csChannelListOrientation :: ChannelListOrientation -- ^ The orientation of the channel list. , _csMe :: User -- ^ The authenticated user. , _csChannels :: ClientChannels -- ^ The channels that we are showing, including their -- message lists. , _csHiddenChannelGroups :: HM.HashMap TeamId (Set ChannelListGroupLabel) -- ^ The set of channel list groups that are currently -- collapsed in the sidebar. , _csPostMap :: HashMap PostId Message -- ^ The map of post IDs to messages. This allows us to -- access messages by ID without having to linearly scan -- channel message lists. , _csUsers :: Users -- ^ All of the users we know about. , _timeZone :: TimeZoneSeries -- ^ The client time zone. , _csConnectionStatus :: ConnectionStatus -- ^ Our view of the connection status. , _csWorkerIsBusy :: Maybe (Maybe Int) -- ^ Whether the async worker thread is busy, and its -- queue length if so. , _csClientConfig :: Maybe ClientConfig -- ^ The Mattermost client configuration, as we understand it. , _csInputHistory :: InputHistory -- ^ The map of per-channel input history for the -- application. We don't distribute the per-channel -- history into the per-channel states (like we do -- for other per-channel state) since keeping it -- under the InputHistory banner lets us use a nicer -- startup/shutdown disk file management API. , _csGlobalEditState :: GlobalEditState -- ^ Bits of global state common to all editors. } -- | All application state specific to a team, along with state specific -- to our user interface's presentation of that team. We include the -- UI state relevant to the team so that we can easily switch which -- team the UI is presenting without having to reinitialize the UI from -- the new team. This allows the user to be engaged in just about any -- application activity while viewing a team, switch to another team, -- and return to the original team and resume what they were doing, all -- without us doing any work. data TeamState = TeamState { _tsFocus :: Z.Zipper ChannelListGroup ChannelListEntry -- ^ The channel sidebar zipper that tracks which channel -- is selected. , _tsTeam :: Team -- ^ The team data. , _tsRecentChannel :: Maybe ChannelId -- ^ The most recently-selected channel, if any. , _tsReturnChannel :: Maybe ChannelId -- ^ The channel to return to after visiting one or more -- unread channels. , _tsModeStack :: NonemptyStack Mode -- ^ The current application mode stack when viewing this -- team. This is used to dispatch to different rendering -- and event handling routines. The current mode is always -- in at the top of the stack. , _tsChannelSelectState :: ChannelSelectState -- ^ The state of the user's input and selection for -- channel selection mode. , _tsPendingChannelChange :: Maybe PendingChannelChange -- ^ A pending channel change that we need to apply once -- the channel in question is available. We set this up -- when we need to change to a channel in the sidebar, but -- it isn't even there yet because we haven't loaded its -- metadata. , _tsViewedMessage :: Maybe (Message, TabbedWindow ChatState MH Name ViewMessageWindowTab) -- ^ Set when the ViewMessage mode is active. The message -- being viewed. Note that this stores a message, not -- a message ID. That's because not all messages have -- message IDs (e.g. client messages) and we still -- want to support viewing of those messages. It's the -- responsibility of code that uses this message to always -- consult the chat state for the latest *version* of any -- message with an ID here, to be sure that the latest -- version is used (e.g. if it gets edited, etc.). , _tsPostListWindow :: PostListWindowState -- ^ The state of the post list window. , _tsUserListWindow :: ListWindowState UserInfo UserSearchScope -- ^ The state of the user list window. , _tsChannelListWindow :: ListWindowState Channel ChannelSearchScope -- ^ The state of the user list window. , _tsNotifyPrefs :: Maybe (Form ChannelNotifyProps MHEvent Name) -- ^ A form for editing the notification preferences for -- the current channel. This is set when entering -- EditNotifyPrefs mode and updated when the user -- changes the form state. , _tsChannelTopicDialog :: ChannelTopicDialogState -- ^ The state for the interactive channel topic editor -- window. , _tsReactionEmojiListWindow :: ListWindowState (Bool, T.Text) () -- ^ The state of the reaction emoji list window. , _tsThemeListWindow :: ListWindowState InternalTheme () -- ^ The state of the theme list window. , _tsChannelListSorting :: ChannelListSorting -- ^ How to sort channels in this team's channel list -- groups , _tsThreadInterface :: Maybe ThreadInterface -- ^ The thread interface for this team for participating -- in a single thread , _tsMessageInterfaceFocus :: MessageInterfaceFocus -- ^ Which message interface is focused for editing input } data MessageInterfaceFocus = FocusThread | FocusCurrentChannel deriving (Eq, Show) messageInterfaceFocusList :: [MessageInterfaceFocus] messageInterfaceFocusList = [ FocusCurrentChannel , FocusThread ] messageInterfaceFocusNext :: TeamState -> TeamState messageInterfaceFocusNext = messageInterfaceFocusWith messageInterfaceFocusList messageInterfaceFocusPrev :: TeamState -> TeamState messageInterfaceFocusPrev = messageInterfaceFocusWith (reverse messageInterfaceFocusList) messageInterfaceFocusWith :: [MessageInterfaceFocus] -> TeamState -> TeamState messageInterfaceFocusWith lst ts = let next = fromJust $ cycleElemAfter cur lst cur = _tsMessageInterfaceFocus ts noThread = isNothing $ _tsThreadInterface ts newFocus = if next == FocusThread && noThread then fromJust $ cycleElemAfter FocusThread lst else next in ts { _tsMessageInterfaceFocus = newFocus } cycleElemAfter :: (Eq a) => a -> [a] -> Maybe a cycleElemAfter e es = if e `notElem` es then Nothing else Just $ head $ drop 1 $ dropWhile (/= e) $ cycle es -- | Handles for the View Message window's tabs. data ViewMessageWindowTab = VMTabMessage -- ^ The message tab. | VMTabReactions -- ^ The reactions tab. deriving (Eq, Show) data PendingChannelChange = ChangeByChannelId TeamId ChannelId (Maybe (MH ())) | ChangeByUserId UserId -- | Startup state information that is constructed prior to building a -- ChatState. data StartupStateInfo = StartupStateInfo { startupStateResources :: ChatResources , startupStateConnectedUser :: User , startupStateTeams :: HM.HashMap TeamId TeamState , startupStateTimeZone :: TimeZoneSeries , startupStateInitialHistory :: InputHistory , startupStateInitialTeam :: TeamId } -- | The state of the channel topic editor window. data ChannelTopicDialogState = ChannelTopicDialogState { _channelTopicDialogEditor :: Editor T.Text Name -- ^ The topic string editor state. , _channelTopicDialogFocus :: FocusRing Name -- ^ The window focus state (editor/buttons) } sortTeamsAlpha :: [Team] -> [Team] sortTeamsAlpha = sortBy (compare `on` (T.strip . sanitizeUserText . teamName)) matchesTeam :: T.Text -> Team -> Bool matchesTeam tName t = let normalizeUserText = normalize . sanitizeUserText normalize = T.strip . T.toLower urlName = normalizeUserText $ teamName t displayName = normalizeUserText $ teamDisplayName t in normalize tName `elem` [displayName, urlName] mkTeamZipperFromIds :: [TeamId] -> Z.Zipper () TeamId mkTeamZipperFromIds tIds = Z.fromList [((), tIds)] teamZipperIds :: Z.Zipper () TeamId -> [TeamId] teamZipperIds = concat . fmap snd . Z.toList -- | The state of channel selection mode. data ChannelSelectState = ChannelSelectState { _channelSelectInput :: Editor Text Name , _channelSelectMatches :: Z.Zipper ChannelListGroup ChannelSelectMatch } emptyChannelSelectState :: TeamId -> ChannelSelectState emptyChannelSelectState tId = ChannelSelectState { _channelSelectInput = editor (ChannelSelectInput tId) (Just 1) "" , _channelSelectMatches = Z.fromList [] } -- | The state of the post list window. data PostListWindowState = PostListWindowState { _postListPosts :: Messages , _postListSelected :: Maybe PostId } data InternalTheme = InternalTheme { internalThemeName :: Text , internalTheme :: Theme , internalThemeDesc :: Text } -- | The state of the search result list window. Type 'a' is the type -- of data in the list. Type 'b' is the search scope type. data ListWindowState a b = ListWindowState { _listWindowSearchResults :: List Name a -- ^ The list of search results currently shown in -- the window. , _listWindowSearchInput :: Editor Text Name -- ^ The editor for the window's search input. , _listWindowSearchScope :: b -- ^ The window's current search scope. , _listWindowSearching :: Bool -- ^ Whether a search is in progress (i.e. whether -- we are currently awaiting a response from a -- search query to the server). , _listWindowEnterHandler :: a -> MH Bool -- ^ The handler to invoke on the selected element -- when the user presses Enter. , _listWindowNewList :: Vec.Vector a -> List Name a -- ^ The function to build a new brick List from a -- vector of search results. , _listWindowFetchResults :: b -> Session -> Text -> IO (Vec.Vector a) -- ^ The function to call to issue a search query -- to the server. , _listWindowRecordCount :: Maybe Int -- ^ The total number of available records, if known. } -- | The scope for searching for users in a user list window. data UserSearchScope = ChannelMembers ChannelId TeamId | ChannelNonMembers ChannelId TeamId | AllUsers (Maybe TeamId) -- | The scope for searching for channels to join. data ChannelSearchScope = AllChannels -- | Actions that can be sent on the websocket to the server. data WebsocketAction = UserTyping UTCTime ChannelId (Maybe PostId) -- ^ user typing in the input box deriving (Read, Show, Eq, Ord) -- * MH Monad -- | Logging context information, in the event that metadata should -- accompany a log message. data LogContext = LogContext { logContextChannelId :: Maybe ChannelId } deriving (Eq, Show) -- | A user fetching strategy. data UserFetch = UserFetchById UserId -- ^ Fetch the user with the specified ID. | UserFetchByUsername Text -- ^ Fetch the user with the specified username. | UserFetchByNickname Text -- ^ Fetch the user with the specified nickname. deriving (Eq, Show) data MHState = MHState { mhUsersToFetch :: [UserFetch] , mhPendingStatusList :: Maybe [UserId] } -- | A value of type 'MH' @a@ represents a computation that can -- manipulate the application state and also request that the -- application quit newtype MH a = MH { fromMH :: R.ReaderT (Maybe LogContext) (St.StateT MHState (EventM Name ChatState)) a } -- | Use a modified logging context for the duration of the specified MH -- action. withLogContext :: (Maybe LogContext -> Maybe LogContext) -> MH a -> MH a withLogContext modifyContext act = MH $ R.withReaderT modifyContext (fromMH act) withLogContextChannelId :: ChannelId -> MH a -> MH a withLogContextChannelId cId act = let f Nothing = Just $ LogContext (Just cId) f (Just c) = Just $ c { logContextChannelId = Just cId } in withLogContext f act -- | Get the current logging context. getLogContext :: MH (Maybe LogContext) getLogContext = MH R.ask -- | Log a message. mhLog :: LogCategory -> Text -> MH () mhLog cat msg = do logger <- mhGetIOLogger liftIO $ logger cat msg -- | Get a logger suitable for use in IO. The logger always logs using -- the MH monad log context at the time of the call to mhGetIOLogger. mhGetIOLogger :: MH (LogCategory -> Text -> IO ()) mhGetIOLogger = do ctx <- getLogContext mgr <- use (to (_crLogManager . _csResources)) return $ ioLogWithManager mgr ctx ioLogWithManager :: LogManager -> Maybe LogContext -> LogCategory -> Text -> IO () ioLogWithManager mgr ctx cat msg = do now <- getCurrentTime let lm = LogMessage { logMessageText = msg , logMessageContext = ctx , logMessageCategory = cat , logMessageTimestamp = now } sendLogMessage mgr lm -- | Run an 'MH' computation in 'EventM'. runMHEvent :: MH () -> EventM Name ChatState () runMHEvent (MH mote) = do let mhSt = MHState { mhUsersToFetch = [] , mhPendingStatusList = Nothing } void $ St.runStateT (R.runReaderT mote Nothing) mhSt scheduleUserFetches :: [UserFetch] -> MH () scheduleUserFetches fs = MH $ do St.modify $ \s -> s { mhUsersToFetch = fs <> mhUsersToFetch s } scheduleUserStatusFetches :: [UserId] -> MH () scheduleUserStatusFetches is = MH $ do St.modify $ \s -> s { mhPendingStatusList = Just is } getScheduledUserFetches :: MH [UserFetch] getScheduledUserFetches = MH $ St.gets mhUsersToFetch getScheduledUserStatusFetches :: MH (Maybe [UserId]) getScheduledUserStatusFetches = MH $ St.gets mhPendingStatusList -- | lift a computation in 'EventM' into 'MH' mh :: EventM Name ChatState a -> MH a mh = MH . R.lift . St.lift generateUUID :: MH UUID generateUUID = liftIO generateUUID_IO generateUUID_IO :: IO UUID generateUUID_IO = randomIO mhZoom :: Lens' ChatState b -> (e -> EventM Name b ()) -> e -> MH () mhZoom ln f event = MH $ R.lift $ St.lift $ zoom ln (f event) mhZoom' :: Lens' ChatState b -> (EventM Name b ()) -> MH () mhZoom' ln f = MH $ R.lift $ St.lift $ zoom ln f mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH () mhSuspendAndResume act = MH $ R.lift $ St.lift $ do st <- St.get Brick.suspendAndResume (act st) mhContinueWithoutRedraw :: MH () mhContinueWithoutRedraw = MH $ R.lift $ St.lift $ Brick.continueWithoutRedraw -- | This will request that after this computation finishes the -- application should exit requestQuit :: MH () requestQuit = MH $ R.lift $ St.lift $ Brick.halt instance Functor MH where fmap f (MH x) = MH (fmap f x) instance Applicative MH where pure x = MH (pure x) MH f <*> MH x = MH (f <*> x) instance Monad MH where return = pure MH x >>= f = MH (x >>= \ x' -> fromMH (f x')) instance St.MonadState ChatState MH where get = MH $ R.lift $ St.lift St.get put = MH . R.lift . St.lift . St.put instance St.MonadIO MH where liftIO = MH . St.liftIO -- | This represents events that we handle in the main application loop. data MHEvent = WSEvent WebsocketEvent -- ^ For events that arise from the websocket | WSActionResponse WebsocketActionResponse -- ^ For responses to websocket actions | RespEvent (MH ()) -- ^ For the result values of async IO operations | RefreshWebsocketEvent -- ^ Tell our main loop to refresh the websocket connection | WebsocketParseError String -- ^ We failed to parse an incoming websocket event | WebsocketDisconnect -- ^ The websocket connection went down. | WebsocketConnect -- ^ The websocket connection came up. | BGIdle -- ^ background worker is idle | BGBusy (Maybe Int) -- ^ background worker is busy (with n requests) | RateLimitExceeded Int -- ^ A request initially failed due to a rate limit but will be -- retried if possible. The argument is the number of seconds in -- which the retry will be attempted. | RateLimitSettingsMissing -- ^ A request denied by a rate limit could not be retried because -- the response contained no rate limit metadata | RequestDropped -- ^ A request was reattempted due to a rate limit and was rate -- limited again | IEvent InternalEvent -- ^ MH-internal events -- | Internal application events. data InternalEvent = DisplayError MHError -- ^ Some kind of application error occurred | LoggingStarted FilePath | LoggingStopped FilePath | LogStartFailed FilePath String | LogDestination (Maybe FilePath) | LogSnapshotSucceeded FilePath | LogSnapshotFailed FilePath String -- ^ Logging events from the logging thread -- | Application errors. data MHError = GenericError T.Text -- ^ A generic error message constructor | NoSuchChannel T.Text -- ^ The specified channel does not exist | NoSuchUser T.Text -- ^ The specified user does not exist | AmbiguousName T.Text -- ^ The specified name matches both a user and a channel | ServerError MattermostError -- ^ A Mattermost server error occurred | ClipboardError T.Text -- ^ A problem occurred trying to deal with yanking or the system -- clipboard | ConfigOptionMissing T.Text -- ^ A missing config option is required to perform an operation | ProgramExecutionFailed T.Text T.Text -- ^ Args: program name, path to log file. A problem occurred when -- running the program. | NoSuchScript T.Text -- ^ The specified script was not found | NoSuchHelpTopic T.Text -- ^ The specified help topic was not found | AttachmentException SomeException -- ^ IO operations for attaching a file threw an exception | BadAttachmentPath T.Text -- ^ The specified file is either a directory or doesn't exist | AsyncErrEvent SomeException -- ^ For errors that arise in the course of async IO operations deriving (Show) -- ** Application State Lenses makeLenses ''ChatResources makeLenses ''ChatState makeLenses ''TeamState makeLenses ''GlobalEditState makeLenses ''PostListWindowState makeLenses ''ListWindowState makeLenses ''ChannelSelectState makeLenses ''UserPreferences makeLenses ''ConnectionInfo makeLenses ''ChannelTopicDialogState Brick.suffixLenses ''Config -- | Given a list of event handlers and an event, try to handle the -- event with the handlers in the specified order. If a handler returns -- False (indicating it did not handle the event), try the next handler -- until either a handler returns True or all handlers are tried. -- Returns True if any handler handled the event or False otherwise. handleEventWith :: [Vty.Event -> MH Bool] -> Vty.Event -> MH Bool handleEventWith [] _ = return False handleEventWith (handler:rest) e = do handled <- handler e if handled then return True else handleEventWith rest e applyTeamOrderPref :: Config -> Maybe [TeamId] -> ChatState -> ChatState applyTeamOrderPref cfg mPrefTIds st = let teams = _csTeams st ourTids = HM.keys teams tIds = case mPrefTIds of Nothing -> [] Just prefTIds -> filter (`elem` ourTids) prefTIds curTId = st^.csCurrentTeamId unmentioned = filter (not . wasMentioned) $ HM.elems teams wasMentioned ts = (teamId $ _tsTeam ts) `elem` tIds zipperTidsBeforeConfigSort = tIds <> (teamId <$> sortTeamsAlpha (_tsTeam <$> unmentioned)) zipperTids = applyTeamSorting st (cfg^.configTeamListSortingL) zipperTidsBeforeConfigSort in st { _csTeamZipper = (Z.findRight ((== curTId) . Just) $ mkTeamZipperFromIds zipperTids) } applyTeamSorting :: ChatState -> TeamListSorting -> [TeamId] -> [TeamId] applyTeamSorting _ TeamListSortDefault tIds = tIds applyTeamSorting st TeamListSortUnreadFirst tIds = let withCount tId = (tId, teamUnreadCount tId st) withCounts = withCount <$> tIds unreadFirst = sortBy (comparing (Down . (> 0) . snd)) withCounts in fst <$> unreadFirst refreshTeamZipper :: MH () refreshTeamZipper = do config <- use (csResources.crConfiguration) tidOrder <- use (csResources.crUserPreferences.userPrefTeamOrder) St.modify (applyTeamOrderPref config tidOrder) applyTeamOrder :: [TeamId] -> MH () applyTeamOrder tIds = do config <- use (csResources.crConfiguration) St.modify (applyTeamOrderPref config $ Just tIds) newState :: StartupStateInfo -> ChatState newState (StartupStateInfo {..}) = let config = _crConfiguration startupStateResources in applyTeamOrderPref config (_userPrefTeamOrder $ _crUserPreferences startupStateResources) $ ChatState { _csResources = startupStateResources , _csLastMouseDownEvent = Nothing , _csGlobalEditState = emptyGlobalEditState , _csVerbatimTruncateSetting = configTruncateVerbatimBlocks config , _csTeamZipper = Z.findRight (== startupStateInitialTeam) $ mkTeamZipperFromIds $ teamId <$> (_tsTeam <$> snd <$> HM.toList startupStateTeams) , _csTeams = startupStateTeams , _csChannelListOrientation = configChannelListOrientation config , _csMe = startupStateConnectedUser , _csChannels = noChannels , _csPostMap = HM.empty , _csUsers = noUsers , _timeZone = startupStateTimeZone , _csConnectionStatus = Connected , _csWorkerIsBusy = Nothing , _csClientConfig = Nothing , _csInputHistory = startupStateInitialHistory , _csHiddenChannelGroups = mempty } getServerBaseUrl :: TeamId -> MH TeamBaseURL getServerBaseUrl tId = do st <- use id return $ serverBaseUrl st tId serverBaseUrl :: ChatState -> TeamId -> TeamBaseURL serverBaseUrl st tId = let baseUrl = connectionDataURL $ _crConn $ _csResources st tName = teamName $ st^.csTeam(tId).tsTeam in TeamBaseURL (TeamURLName $ sanitizeUserText tName) baseUrl getSession :: MH Session getSession = use (csResources.crSession) getResourceSession :: ChatResources -> Session getResourceSession = _crSession whenMode :: TeamId -> Mode -> MH () -> MH () whenMode tId m act = do curMode <- top <$> use (csTeam(tId).tsModeStack) when (curMode == m) act pushMode :: TeamId -> Mode -> MH () pushMode tId m = do St.modify (pushMode' tId m) mh invalidateCache replaceMode :: TeamId -> Mode -> MH () replaceMode tId m = popMode tId >> pushMode tId m popMode :: TeamId -> MH () popMode tId = do s <- use (csTeam(tId).tsModeStack) let (s', topVal) = pop s case topVal of Nothing -> return () Just _ -> do csTeam(tId).tsModeStack .= s' mh invalidateCache pushMode' :: TeamId -> Mode -> ChatState -> ChatState pushMode' tId m st = let s = st^.csTeam(tId).tsModeStack in if top s == m then st else st & csTeam(tId).tsModeStack %~ (push m) -- ** Utility Lenses csCurrentChannelId :: TeamId -> SimpleGetter ChatState (Maybe ChannelId) csCurrentChannelId tId = csTeam(tId).tsFocus.to Z.focus.to (fmap channelListEntryChannelId) teamUnreadCount :: TeamId -> ChatState -> Int teamUnreadCount tId st = sum $ fmap (nonDMChannelListGroupUnread . fst) $ Z.toList $ st^.csTeam(tId).tsFocus withCurrentTeam :: (TeamId -> MH ()) -> MH () withCurrentTeam f = do mtId <- use csCurrentTeamId case mtId of Nothing -> return () Just tId -> f tId withCurrentChannel :: TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH () withCurrentChannel tId f = do mcId <- use $ csCurrentChannelId tId case mcId of Nothing -> return () Just cId -> do mChan <- preuse $ csChannel cId case mChan of Just ch -> f cId ch _ -> return () withCurrentChannel' :: TeamId -> (ChannelId -> ClientChannel -> MH (Maybe a)) -> MH (Maybe a) withCurrentChannel' tId f = do mcId <- use $ csCurrentChannelId tId case mcId of Nothing -> return Nothing Just cId -> do mChan <- preuse $ csChannel cId case mChan of Just ch -> f cId ch _ -> return Nothing csCurrentTeamId :: SimpleGetter ChatState (Maybe TeamId) csCurrentTeamId = csTeamZipper.to Z.focus csChannelMessageInterface :: ChannelId -> Lens' ChatState ChannelMessageInterface csChannelMessageInterface cId = csChannels.maybeChannelByIdL cId.singular _Just.ccMessageInterface maybeChannelMessageInterface :: ChannelId -> Traversal' ChatState ChannelMessageInterface maybeChannelMessageInterface cId = csChannels.maybeChannelByIdL cId._Just.ccMessageInterface channelEditor :: ChannelId -> Lens' ChatState (EditState Name) channelEditor cId = csChannels.maybeChannelByIdL cId.singular _Just.ccMessageInterface.miEditor channelMessageSelect :: ChannelId -> Lens' ChatState MessageSelectState channelMessageSelect cId = csChannels.maybeChannelByIdL cId.singular _Just.ccMessageInterface.miMessageSelect csTeam :: TeamId -> Lens' ChatState TeamState csTeam tId = lens (\ st -> st ^. csTeams . at tId ^?! _Just) (\ st t -> st & csTeams . at tId .~ Just t) teamMode :: TeamState -> Mode teamMode = top . _tsModeStack teamModes :: TeamState -> [Mode] teamModes = stackToList . _tsModeStack getTeamMode :: TeamId -> MH Mode getTeamMode tId = teamMode <$> use (csTeam(tId)) channelListEntryUserId :: ChannelListEntry -> Maybe UserId channelListEntryUserId e = case channelListEntryType e of CLUserDM uId -> Just uId _ -> Nothing userIdsFromZipper :: Z.Zipper ChannelListGroup ChannelListEntry -> [UserId] userIdsFromZipper z = concat $ (catMaybes . fmap channelListEntryUserId . snd) <$> Z.toList z entryIsDMEntry :: ChannelListEntry -> Bool entryIsDMEntry e = case channelListEntryType e of CLUserDM {} -> True CLGroupDM {} -> True CLChannel {} -> False csChannel :: ChannelId -> Traversal' ChatState ClientChannel csChannel cId = csChannels . channelByIdL cId csChannelMessages :: ChannelId -> Traversal' ChatState Messages csChannelMessages cId = csChannelMessageInterface(cId).miMessages withChannel :: ChannelId -> (ClientChannel -> MH ()) -> MH () withChannel cId = withChannelOrDefault cId () withChannelOrDefault :: ChannelId -> a -> (ClientChannel -> MH a) -> MH a withChannelOrDefault cId deflt mote = do chan <- preuse (csChannel(cId)) case chan of Nothing -> return deflt Just c -> mote c type MHKeyEventHandler = KeyEventHandler KeyEvent MH mhHandleKeyboardEvent :: (KeyConfig KeyEvent -> KeyDispatcher KeyEvent MH) -- ^ The function to build a key handler map from -- a key configuration. -> Vty.Event -- ^ The event to handle. -> MH Bool mhHandleKeyboardEvent mkDispatcher (Vty.EvKey k mods) = do config <- use (csResources.crConfiguration) handleKey (mkDispatcher $ configUserKeys config) k mods mhHandleKeyboardEvent _ _ = return False -- | Create a key dispatcher, but convert errors about conflict bindings -- into a runtime exception with 'error'. Where we use this, it's safe -- to use because we do a startup check for keybinding conflicts in -- most application modes, which means that by the time we get around -- to calling this function, the modes have already been checked and -- have been found free of conflicts. However, there could be situations -- in the future where we can't detect collisions at startup due to -- dynamically built handler lists. In those cases, this would cause -- the program to crash with a detailed error about the conflicting key -- binding. unsafeKeyDispatcher :: (Ord k) => KeyConfig k -> [KeyEventHandler k m] -> KeyDispatcher k m unsafeKeyDispatcher cfg hs = case keyDispatcher cfg hs of Right d -> d Left conflicts -> error $ T.unpack $ "Error: conflicting key bindings:\n" <> bindingConflictMessage cfg conflicts bindingConflictMessage :: (Ord k) => KeyConfig k -> [(Binding, [KeyHandler k m])] -> T.Text bindingConflictMessage cfg conflicts = msg where msg = T.intercalate "\n" sections sections = mkSection <$> conflicts mkSection (key, handlers) = let handlerLines = handlerLine <$> handlers handlerLine h = let desc = handlerDescription $ kehHandler $ khHandler h trigger = case kehEventTrigger $ khHandler h of ByEvent e -> "event '" <> fromJust (keyEventName (keyConfigEvents cfg) e) <> "'" ByKey b -> "fixed key '" <> ppBinding b <> "'" in " '" <> desc <> "', triggered by " <> trigger in T.intercalate "\n" $ [ "Conflicting key binding: " <> ppBinding key , "Handlers:" ] <> handlerLines -- ** 'ChatState' Helper Functions raiseInternalEvent :: InternalEvent -> MH () raiseInternalEvent ev = do queue <- use (csResources.crEventQueue) writeBChan queue (IEvent ev) writeBChan :: (MonadIO m) => BCH.BChan MHEvent -> MHEvent -> m () writeBChan chan e = do written <- liftIO $ BCH.writeBChanNonBlocking chan e when (not written) $ error $ "mhSendEvent: BChan full, please report this as a bug!" -- | Log and raise an error. mhError :: MHError -> MH () mhError err = do mhLog LogError $ T.pack $ show err raiseInternalEvent (DisplayError err) isMine :: ChatState -> Message -> Bool isMine st msg = case msg^.mUser of UserI _ uid -> uid == myUserId st _ -> False getMessageForPostId :: ChatState -> PostId -> Maybe Message getMessageForPostId st pId = st^.csPostMap.at(pId) getParentMessage :: ChatState -> Message -> Maybe Message getParentMessage st msg | InReplyTo pId <- msg^.mInReplyToMsg = st^.csPostMap.at(pId) | otherwise = Nothing getReplyRootMessage :: Message -> MH Message getReplyRootMessage msg = do case postRootId =<< (msg^.mOriginalPost) of Nothing -> return msg Just rootId -> do st <- use id case getMessageForPostId st rootId of -- NOTE: this case should never happen. This is the -- case where a message has a root post ID but we -- don't have a copy of the root post in storage. This -- shouldn't happen because whenever we add a message -- to a channel, we always fetch the parent post and -- store it if it is in a thread. That should mean that -- whenever we reply to a post, if that post is itself -- a reply, we should have its root post in storage -- and this case should never match. Even though it -- shouldn't happen, rather than raising a BUG exception -- here we'll just fall back to the input message. Nothing -> return msg Just m -> return m setUserStatus :: UserId -> Text -> MH () setUserStatus uId t = do csUsers %= modifyUserById uId (uiStatus .~ statusFromText t) cs <- use csChannels forM_ (allTeamIds cs) $ \tId -> mh $ invalidateCacheEntry $ ChannelSidebar tId usernameForUserId :: UserId -> ChatState -> Maybe Text usernameForUserId uId st = _uiName <$> findUserById uId (st^.csUsers) displayNameForUserId :: UserId -> ChatState -> Maybe Text displayNameForUserId uId st = do u <- findUserById uId (st^.csUsers) return $ displayNameForUser u (st^.csClientConfig) (st^.csResources.crUserPreferences) -- | Note: this only searches users we have already loaded. Be -- aware that if you think you need a user we haven't fetched, use -- withFetchedUser! userIdForUsername :: Text -> ChatState -> Maybe UserId userIdForUsername name st = fst <$> (findUserByUsername name $ st^.csUsers) channelIdByChannelName :: TeamId -> Text -> ChatState -> Maybe ChannelId channelIdByChannelName tId name st = let matches (_, cc) = cc^.ccInfo.cdName == (trimChannelSigil name) && cc^.ccInfo.cdTeamId == (Just tId) in listToMaybe $ fst <$> filteredChannels matches (st^.csChannels) channelIdByUsername :: Text -> ChatState -> Maybe ChannelId channelIdByUsername name st = do uId <- userIdForUsername name st getDmChannelFor uId (st^.csChannels) useNickname :: ChatState -> Bool useNickname st = useNickname' (st^.csClientConfig) (st^.csResources.crUserPreferences) trimChannelSigil :: Text -> Text trimChannelSigil n | normalChannelSigil `T.isPrefixOf` n = T.tail n | otherwise = n addNewUser :: UserInfo -> MH () addNewUser u = do csUsers %= addUser u -- Invalidate the cache because channel message rendering may need -- to get updated if this user authored posts in any channels. mh invalidateCache data SidebarUpdate = SidebarUpdateImmediate | SidebarUpdateDeferred deriving (Eq, Show) resetAutocomplete :: Traversal' ChatState (EditState n) -> MH () resetAutocomplete which = do which.esAutocomplete .= Nothing which.esAutocompletePending .= Nothing -- * Slash Commands -- | The 'CmdArgs' type represents the arguments to a slash-command; the -- type parameter represents the argument structure. data CmdArgs :: K.Type -> K.Type where NoArg :: CmdArgs () LineArg :: Text -> CmdArgs Text UserArg :: CmdArgs rest -> CmdArgs (Text, rest) ChannelArg :: CmdArgs rest -> CmdArgs (Text, rest) TokenArg :: Text -> CmdArgs rest -> CmdArgs (Text, rest) -- | A 'CmdExec' value represents the implementation of a command when -- provided with its arguments type CmdExec a = a -> MH () -- | A 'Cmd' packages up a 'CmdArgs' specifier and the 'CmdExec' -- implementation with a name and a description. data Cmd = forall a. Cmd { cmdName :: Text , cmdDescr :: Text , cmdArgSpec :: CmdArgs a , cmdAction :: CmdExec a } -- | Helper function to extract the name out of a 'Cmd' value commandName :: Cmd -> Text commandName (Cmd name _ _ _ ) = name -- * Channel Updates and Notifications userList :: ChatState -> [UserInfo] userList st = filter showUser $ allUsers (st^.csUsers) where showUser u = not (isSelf u) && (u^.uiInTeam) isSelf u = (myUserId st) == (u^.uiId) allUserIds :: ChatState -> [UserId] allUserIds st = getAllUserIds $ st^.csUsers -- BEWARE: you probably don't want this, but instead -- State.Users.withFetchedUser, since this only looks up users in the -- collection we have already loaded rather than all valid users on the -- server. userById :: UserId -> ChatState -> Maybe UserInfo userById uId st = findUserById uId (st^.csUsers) myUserId :: ChatState -> UserId myUserId st = myUser st ^. userIdL myUser :: ChatState -> User myUser st = st^.csMe myUsername :: ChatState -> Text myUsername st = userUsername $ st^.csMe -- BEWARE: you probably don't want this, but instead -- State.Users.withFetchedUser, since this only looks up users in the -- collection we have already loaded rather than all valid users on the -- server. userByUsername :: Text -> ChatState -> Maybe UserInfo userByUsername name st = do snd <$> (findUserByUsername name $ st^.csUsers) -- BEWARE: you probably don't want this, but instead -- State.Users.withFetchedUser, since this only looks up users in the -- collection we have already loaded rather than all valid users on the -- server. userByNickname :: Text -> ChatState -> Maybe UserInfo userByNickname name st = snd <$> (findUserByNickname name $ st^.csUsers) getUsers :: MH Users getUsers = use csUsers -- * HighlightSet type UserSet = Set Text type ChannelSet = Set Text -- | The set of usernames, channel names, and language names used for -- highlighting when rendering messages. data HighlightSet = HighlightSet { hUserSet :: Set Text , hChannelSet :: Set Text , hSyntaxMap :: SyntaxMap } emptyHSet :: HighlightSet emptyHSet = HighlightSet Set.empty Set.empty mempty getHighlightSet :: ChatState -> TeamId -> HighlightSet getHighlightSet st tId = HighlightSet { hUserSet = addSpecialUserMentions $ getUsernameSet $ st^.csUsers , hChannelSet = getChannelNameSet tId $ st^.csChannels , hSyntaxMap = st^.csResources.crSyntaxMap } attrNameToConfig :: Brick.AttrName -> Text attrNameToConfig = T.pack . intercalate "." . Brick.attrNameComponents -- From: https://docs.mattermost.com/help/messaging/mentioning-teammates.html specialUserMentions :: [T.Text] specialUserMentions = ["all", "channel", "here"] addSpecialUserMentions :: Set Text -> Set Text addSpecialUserMentions s = foldr Set.insert s specialUserMentions getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator getNewMessageCutoff cId st = do cc <- st^?csChannel(cId) return $ cc^.ccInfo.cdNewMessageIndicator getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe ServerTime getEditedMessageCutoff cId st = do cc <- st^?csChannel(cId) cc^.ccInfo.cdEditedMessageThreshold clearChannelUnreadStatus :: ChannelId -> MH () clearChannelUnreadStatus cId = do mh $ invalidateCacheEntry (MessageInterfaceMessages $ MessageInput cId) csChannel(cId) %= (clearNewMessageIndicator . clearEditedThreshold) moveLeft :: (Eq a) => a -> [a] -> [a] moveLeft v as = case elemIndex v as of Nothing -> as Just 0 -> as Just i -> let (h, t) = splitAt i as in init h <> [v, last h] <> tail t moveRight :: (Eq a) => a -> [a] -> [a] moveRight v as = case elemIndex v as of Nothing -> as Just i | i == length as - 1 -> as | otherwise -> let (h, t) = splitAt i as in h <> [head (tail t), v] <> (tail (tail t)) resultToWidget :: Result n -> Widget n resultToWidget = Widget Fixed Fixed . return threadInterface :: (HasCallStack) => TeamId -> Traversal' ChatState ThreadInterface threadInterface tId = maybeThreadInterface(tId)._Just -- An unsafe lens to get the specified team's thread interface. Assumes -- the interface is present; if not, this crashes. Intended for places -- where you know the interface will be present due to other state and -- don't want to deal with Maybe. unsafeThreadInterface :: (HasCallStack) => TeamId -> Lens' ChatState ThreadInterface unsafeThreadInterface tId = maybeThreadInterface(tId).singular _Just -- A safe version of unsafeThreadInterface. maybeThreadInterface :: TeamId -> Lens' ChatState (Maybe ThreadInterface) maybeThreadInterface tId = csTeam(tId).tsThreadInterface threadInterfaceEmpty :: TeamId -> MH Bool threadInterfaceEmpty tId = do mLen <- preuse (maybeThreadInterface(tId)._Just.miMessages.to messagesLength) case mLen of Nothing -> return True Just len -> return $ len == 0 withThreadInterface :: TeamId -> ChannelId -> MH () -> MH () withThreadInterface tId cId act = do mCid <- preuse (maybeThreadInterface(tId)._Just.miChannelId) case mCid of Just i | i == cId -> act _ -> return () threadInterfaceDeleteWhere :: TeamId -> ChannelId -> (Message -> Bool) -> MH () threadInterfaceDeleteWhere tId cId f = withThreadInterface tId cId $ do maybeThreadInterface(tId)._Just.miMessages.traversed.filtered f %= (& mDeleted .~ True) modifyThreadMessages :: TeamId -> ChannelId -> (Messages -> Messages) -> MH () modifyThreadMessages tId cId f = do withThreadInterface tId cId $ do maybeThreadInterface(tId)._Just.miMessages %= f modifyEachThreadMessage :: TeamId -> ChannelId -> (Message -> Message) -> MH () modifyEachThreadMessage tId cId f = do withThreadInterface tId cId $ do maybeThreadInterface(tId)._Just.miMessages.traversed %= f