{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} module Matterhorn.Types ( ConnectionStatus(..) , HelpTopic(..) , MessageSelectState(..) , ProgramOutput(..) , MHEvent(..) , InternalEvent(..) , Name(..) , ChannelSelectMatch(..) , StartupStateInfo(..) , MHError(..) , AttachmentData(..) , CPUUsagePolicy(..) , SemEq(..) , tabbedWindow , getCurrentTabbedWindowEntry , tabbedWindowNextTab , tabbedWindowPreviousTab , runTabShowHandlerFor , getServerBaseUrl , serverBaseUrl , TabbedWindow(..) , TabbedWindowEntry(..) , TabbedWindowTemplate(..) , ConnectionInfo(..) , SidebarUpdate(..) , PendingChannelChange(..) , ViewMessageWindowTab(..) , clearChannelUnreadStatus , ChannelListEntry(..) , ChannelListEntryType(..) , ChannelListSorting(..) , ChannelListOrientation(..) , channelListEntryUserId , userIdsFromZipper , entryIsDMEntry , ciHostname , ciPort , ciUrlPath , ciUsername , ciOTPToken , ciPassword , ciType , ciAccessToken , newChannelTopicDialog , ChannelTopicDialogState(..) , channelTopicDialogEditor , channelTopicDialogFocus , resultToWidget , newSaveAttachmentDialog , SaveAttachmentDialogState(..) , attachmentPathEditor , attachmentPathDialogFocus , Config(..) , configUserL , configHostL , configTeamL , configPortL , configUrlPathL , configPassL , configTokenL , configTimeFormatL , configDateFormatL , configThemeL , configThemeCustomizationFileL , configSmartBacktickL , configSmartEditingL , configURLOpenCommandL , configURLOpenCommandInteractiveL , configActivityNotifyCommandL , configActivityNotifyVersionL , configActivityBellL , configTruncateVerbatimBlocksL , configChannelListSortingL , configShowMessageTimestampsL , configShowBackgroundL , configShowMessagePreviewL , configShowChannelListL , configShowExpandedChannelTopicsL , configEnableAspellL , configAspellDictionaryL , configUnsafeUseHTTPL , configValidateServerCertificateL , configChannelListWidthL , configLogMaxBufferSizeL , configShowOlderEditsL , configShowTypingIndicatorL , configSendTypingNotificationsL , configAbsPathL , configUserKeysL , configHyperlinkingModeL , configSyntaxDirsL , configDirectChannelExpirationDaysL , configCpuUsagePolicyL , configDefaultAttachmentPathL , configChannelListOrientationL , configMouseModeL , NotificationVersion(..) , HelpScreen(..) , PasswordSource(..) , TokenSource(..) , MatchType(..) , Mode(..) , ChannelSelectPattern(..) , PostListContents(..) , AuthenticationException(..) , BackgroundInfo(..) , RequestChan , UserFetch(..) , writeBChan , InternalTheme(..) , attrNameToConfig , sortTeams , matchesTeam , mkTeamZipper , mkTeamZipperFromIds , teamZipperIds , mkChannelZipperList , ChannelListGroup(..) , ChannelListGroupLabel(..) , nonDMChannelListGroupUnread , channelListGroupNames , trimChannelSigil , ChannelSelectState(..) , channelSelectMatches , channelSelectInput , emptyChannelSelectState , TeamState(..) , tsFocus , tsMode , tsPendingChannelChange , tsRecentChannel , tsReturnChannel , tsEditState , tsMessageSelect , tsTeam , tsChannelSelectState , tsUrlList , tsViewedMessage , tsPostListOverlay , tsUserListOverlay , tsChannelListOverlay , tsNotifyPrefs , tsChannelTopicDialog , tsReactionEmojiListOverlay , tsThemeListOverlay , tsSaveAttachmentDialog , tsChannelListSorting , ChatState , newState , newTeamState , withCurrentChannel , withCurrentChannel' , withCurrentTeam , csTeamZipper , csTeams , csTeam , csChannelListOrientation , csResources , csLastMouseDownEvent , csVerbatimTruncateSetting , csCurrentChannelId , csCurrentTeamId , csPostMap , csUsers , csHiddenChannelGroups , csConnectionStatus , csWorkerIsBusy , csChannel , csChannels , csClientConfig , csInputHistory , csMe , timeZone , whenMode , setMode , setMode' , ChatEditState , emptyEditState , cedAttachmentList , cedFileBrowser , unsafeCedFileBrowser , cedYankBuffer , cedSpellChecker , cedMisspellings , cedEditMode , cedEphemeral , cedEditor , cedAutocomplete , cedAutocompletePending , cedJustCompleted , AutocompleteState(..) , acPreviousSearchString , acCompletionList , acCachedResponses , acType , AutocompletionType(..) , CompletionSource(..) , AutocompleteAlternative(..) , autocompleteAlternativeReplacement , SpecialMention(..) , specialMentionName , isSpecialMention , PostListOverlayState , postListSelected , postListPosts , UserSearchScope(..) , ChannelSearchScope(..) , ListOverlayState , listOverlaySearchResults , listOverlaySearchInput , listOverlaySearchScope , listOverlaySearching , listOverlayEnterHandler , listOverlayNewList , listOverlayFetchResults , listOverlayRecordCount , listOverlayReturnMode , getUsers , ChatResources(..) , crUserPreferences , crEventQueue , crTheme , crStatusUpdateChan , crSubprocessLog , crWebsocketActionChan , crWebsocketThreadId , crRequestQueue , crFlaggedPosts , crConn , crConfiguration , crSyntaxMap , crLogManager , 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 , mhHandleEventLensed , mhHandleEventLensed' , mhContinueWithoutRedraw , St.gets , mhError , mhLog , mhGetIOLogger , ioLogWithManager , LogContext(..) , withLogContext , withLogContextChannelId , getLogContext , LogMessage(..) , LogCommand(..) , LogCategory(..) , LogManager(..) , startLoggingToFile , stopLoggingToFile , requestLogSnapshot , requestLogDestination , sendLogMessage , requestQuit , getMessageForPostId , getParentMessage , getReplyRootMessage , resetSpellCheckTimer , 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.Channels , module Matterhorn.Types.Messages , module Matterhorn.Types.Posts , module Matterhorn.Types.Users ) where import Prelude () import Matterhorn.Prelude import qualified Graphics.Vty as Vty import qualified Brick import Brick ( EventM, Next, Widget(..), Size(..), Result ) import Brick.Focus ( FocusRing, 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, applyEdit ) import Brick.Widgets.List ( List, list ) import qualified Brick.Widgets.FileBrowser as FB import Control.Concurrent ( ThreadId ) import Control.Concurrent.Async ( Async ) import qualified Control.Concurrent.STM as STM import Control.Exception ( SomeException ) import qualified Control.Monad.Fail as MHF import qualified Control.Monad.State as St import qualified Control.Monad.Reader as R import qualified Data.Set as Set import qualified Data.ByteString as BS import qualified Data.Foldable as F import Data.Function ( on ) import qualified Data.Kind as K import Data.Maybe ( fromJust ) import Data.Ord ( comparing ) import qualified Data.HashMap.Strict as HM import Data.List ( sortBy, nub, elemIndex, partition ) import qualified Data.Sequence as Seq import qualified Data.Text as T import qualified Data.Text.Zipper as Z2 import Data.Time.Clock ( getCurrentTime, addUTCTime ) import Data.UUID ( UUID ) import qualified Data.Vector as Vec import Lens.Micro.Platform ( at, makeLenses, lens, (^?!), (.=) , (%=), (.~), _Just, Traversal', to , SimpleGetter ) 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.Channels import Matterhorn.Types.DirectionalSeq ( emptyDirSeq ) import Matterhorn.Types.KeyEvents import Matterhorn.Types.Messages import Matterhorn.Types.Posts import Matterhorn.Types.RichText ( TeamBaseURL(..), TeamURLName(..) ) import Matterhorn.Types.Users import qualified Matterhorn.Zipper as Z -- * Configuration -- | A notification version for the external notifier data NotificationVersion = NotifyV1 | NotifyV2 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) -- | 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) data ChannelListGroupLabel = ChannelGroupPublicChannels | ChannelGroupPrivateChannels | ChannelGroupFavoriteChannels | ChannelGroupDirectMessages deriving (Eq, Ord, Show) channelListGroupNames :: [(T.Text, ChannelListGroupLabel)] channelListGroupNames = [ ("public", ChannelGroupPublicChannels) , ("private", ChannelGroupPrivateChannels) , ("favorite", ChannelGroupFavoriteChannels) , ("direct", ChannelGroupDirectMessages) ] nonDMChannelListGroupUnread :: ChannelListGroup -> Int nonDMChannelListGroupUnread g = case channelListGroupLabel g of ChannelGroupDirectMessages -> 0 _ -> channelListGroupUnread g -- | The type of channel list entries. data ChannelListEntry = ChannelListEntry { channelListEntryChannelId :: ChannelId , channelListEntryType :: ChannelListEntryType , channelListEntryUnread :: Bool , channelListEntrySortValue :: T.Text , channelListEntryFavorite :: Bool , channelListEntryMuted :: Bool } deriving (Eq, Show, Ord) data ChannelListEntryType = CLChannel -- ^ A non-DM entry | CLUserDM UserId -- ^ A single-user DM entry | CLGroupDM -- ^ A multi-user DM entry deriving (Eq, Show, Ord) data ChannelListSorting = ChannelListSortDefault | ChannelListSortUnreadFirst 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. , 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 , 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 -- ^ 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. , configMouseMode :: Bool -- ^ Whether to enable mouse support in matterhorn } 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) -- * Internal Names and References -- | This 'Name' type is the type used in 'brick' to identify various -- parts of the interface. data Name = ChannelMessages ChannelId | MessageInput TeamId | ChannelList TeamId | HelpViewport | HelpText | ScriptHelpText | ThemeHelpText | SyntaxHighlightHelpText | KeybindingHelpText | ChannelSelectString TeamId | ChannelSelectEntry ChannelSelectMatch | CompletionAlternatives TeamId | CompletionList TeamId | JoinChannelList TeamId | UrlList TeamId | MessagePreviewViewport TeamId | ThemeListSearchInput TeamId | UserListSearchInput TeamId | JoinChannelListSearchInput TeamId | UserListSearchResults TeamId | ThemeListSearchResults TeamId | ViewMessageArea TeamId | ViewMessageReactionsArea TeamId | ChannelSidebar TeamId | ChannelSelectInput TeamId | AttachmentList TeamId | AttachmentFileBrowser TeamId | MessageReactionsArea TeamId | ReactionEmojiList TeamId | ReactionEmojiListInput TeamId | TabbedWindowTabBar TeamId | MuteToggleField TeamId | ChannelMentionsField TeamId | DesktopNotificationsField TeamId (WithDefault NotifyOption) | PushNotificationsField TeamId (WithDefault NotifyOption) | ChannelTopicEditor TeamId | ChannelTopicSaveButton TeamId | ChannelTopicCancelButton TeamId | ChannelTopicEditorPreview TeamId | ChannelTopic ChannelId | TeamList | ClickableChannelListEntry ChannelId | ClickableTeamListEntry TeamId | ClickableURL Name Int LinkTarget | ClickableURLInMessage MessageId Int LinkTarget | ClickableUsernameInMessage MessageId Int Text | ClickableUsername Name Int Text | ClickableURLListEntry Int LinkTarget | ClickableReactionInMessage PostId Text (Set UserId) | ClickableReaction PostId Text (Set UserId) | ClickableAttachment FileId | ClickableChannelListGroupHeading ChannelListGroupLabel | AttachmentPathEditor TeamId | AttachmentPathSaveButton TeamId | AttachmentPathCancelButton TeamId | RenderedMessage MessageId | ReactionEmojiListOverlayEntry (Bool, T.Text) | SelectedChannelListEntry TeamId | VScrollBar Brick.ClickableScrollbarElement Name deriving (Eq, Show, Ord) -- | 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 (ClickableURLInMessage mId1 _ t1) (ClickableURLInMessage mId2 _ t2) = mId1 == mId2 && t1 == t2 semeq (ClickableUsernameInMessage mId1 _ n) (ClickableUsernameInMessage mId2 _ n2) = mId1 == mId2 && n == n2 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 -- | A match in channel selection mode. data ChannelSelectMatch = ChannelSelectMatch { nameBefore :: Text -- ^ The content of the match before the user's -- matching input. , nameMatched :: Text -- ^ The potion of the name that matched the -- user's input. , nameAfter :: Text -- ^ The portion of the name that came after the -- user's matching input. , matchFull :: Text -- ^ The full string for this entry so it doesn't -- have to be reassembled from the parts above. , matchEntry :: ChannelListEntry -- ^ The original entry data corresponding to the -- text match. } deriving (Eq, Show, Ord) 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 } -- | A "special" mention that does not map to a specific user, but is an -- alias that the server uses to notify users. data SpecialMention = MentionAll -- ^ @all: notify everyone in the channel. | MentionChannel -- ^ @channel: notify everyone in the channel. data AutocompleteAlternative = UserCompletion User Bool -- ^ User, plus whether the user is in the channel that triggered -- the autocomplete | SpecialMention SpecialMention -- ^ A special mention. | ChannelCompletion Bool Channel -- ^ Channel, plus whether the user is a member of the channel | SyntaxCompletion Text -- ^ Name of a skylighting syntax definition | CommandCompletion CompletionSource Text Text Text -- ^ Source, name of a slash command, argspec, and description | EmojiCompletion Text -- ^ The text of an emoji completion -- | The source of an autocompletion alternative. data CompletionSource = Server | Client deriving (Eq, Show) specialMentionName :: SpecialMention -> Text specialMentionName MentionChannel = "channel" specialMentionName MentionAll = "all" isSpecialMention :: T.Text -> Bool isSpecialMention n = isJust $ lookup (T.toLower $ trimUserSigil n) pairs where pairs = mkPair <$> mentions mentions = [ MentionChannel , MentionAll ] mkPair v = (specialMentionName v, v) autocompleteAlternativeReplacement :: AutocompleteAlternative -> Text autocompleteAlternativeReplacement (EmojiCompletion e) = ":" <> e <> ":" autocompleteAlternativeReplacement (SpecialMention m) = addUserSigil $ specialMentionName m autocompleteAlternativeReplacement (UserCompletion u _) = addUserSigil $ userUsername u autocompleteAlternativeReplacement (ChannelCompletion _ c) = normalChannelSigil <> (sanitizeUserText $ channelName c) autocompleteAlternativeReplacement (SyntaxCompletion t) = "```" <> t autocompleteAlternativeReplacement (CommandCompletion _ t _ _) = "/" <> t -- | The type of data that the autocompletion logic supports. We use -- this to track the kind of completion underway in case the type of -- completion needs to change. data AutocompletionType = ACUsers | ACChannels | ACCodeBlockLanguage | ACEmoji | ACCommands deriving (Eq, Show) data AutocompleteState = AutocompleteState { _acPreviousSearchString :: Text -- ^ The search string used for the -- currently-displayed autocomplete results, for -- use in deciding whether to issue another server -- query , _acCompletionList :: List Name AutocompleteAlternative -- ^ The list of alternatives that the user -- selects from , _acType :: AutocompletionType -- ^ The type of data that we're completing , _acCachedResponses :: HM.HashMap Text [AutocompleteAlternative] -- ^ A cache of alternative lists, keyed on search -- string, for use in avoiding server requests. -- The idea here is that users type quickly enough -- (and edit their input) that would normally lead -- to rapid consecutive requests, some for the -- same strings during editing, that we can avoid -- that by caching them here. Note that this cache -- gets destroyed whenever autocompletion is not -- on, so this cache does not live very long. } -- | The 'ChatEditState' value contains the editor widget itself as well -- as history and metadata we need for editing-related operations. data ChatEditState = ChatEditState { _cedEditor :: Editor Text Name , _cedEditMode :: EditMode , _cedEphemeral :: EphemeralEditState , _cedYankBuffer :: Text , _cedSpellChecker :: Maybe (Aspell, IO ()) , _cedMisspellings :: Set Text , _cedAutocomplete :: Maybe AutocompleteState -- ^ The autocomplete state. The autocompletion UI is -- showing only when this state is present. , _cedAutocompletePending :: Maybe Text -- ^ The search string associated with the latest -- in-flight autocompletion request. This is used to -- determine whether any (potentially late-arriving) -- API responses are for stale queries since the user -- can type more quickly than the server can get us -- the results, and we wouldn't want to show results -- associated with old editor states. , _cedAttachmentList :: List Name AttachmentData -- ^ The list of attachments to be uploaded with the -- post being edited. , _cedFileBrowser :: Maybe (FB.FileBrowser Name) -- ^ The browser for selecting attachment files. -- This is a Maybe because the instantiation of the -- FileBrowser causes it to read and ingest the -- target directory, so this action is deferred -- until the browser is needed. , _cedJustCompleted :: Bool -- A flag that indicates whether the most recent -- editing event was a tab-completion. This is used by -- the smart trailing space handling. } -- | An attachment. data AttachmentData = AttachmentData { attachmentDataFileInfo :: FB.FileInfo , attachmentDataBytes :: BS.ByteString } deriving (Eq, Show) -- | We can initialize a new 'ChatEditState' value with just an edit -- history, which we save locally. emptyEditState :: TeamId -> ChatEditState emptyEditState tId = ChatEditState { _cedEditor = editor (MessageInput tId) Nothing "" , _cedEphemeral = defaultEphemeralEditState , _cedEditMode = NewPost , _cedYankBuffer = "" , _cedSpellChecker = Nothing , _cedMisspellings = mempty , _cedAutocomplete = Nothing , _cedAutocompletePending = Nothing , _cedAttachmentList = list (AttachmentList tId) mempty 1 , _cedFileBrowser = Nothing , _cedJustCompleted = False } -- | 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 ()))) -- | The 'HelpScreen' type represents the set of possible 'Help' -- dialogues we have to choose from. data HelpScreen = MainHelp | ScriptHelp | ThemeHelp | SyntaxHighlightHelp | KeybindingHelp deriving (Eq, Show) -- | Help topics data HelpTopic = HelpTopic { helpTopicName :: Text , helpTopicDescription :: Text , helpTopicScreen :: HelpScreen , helpTopicViewportName :: Name } deriving (Eq, Show) -- | Mode type for the current contents of the post list overlay 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 Mode | ChannelSelect | UrlSelect | LeaveChannelConfirm | DeleteChannelConfirm | MessageSelect | MessageSelectDeleteConfirm | PostListOverlay PostListContents | UserListOverlay | ReactionEmojiListOverlay | ChannelListOverlay | ThemeListOverlay | ViewMessage | ManageAttachments | ManageAttachmentsBrowseFiles | EditNotifyPrefs | ChannelTopicWindow | SaveAttachmentWindow LinkChoice deriving (Eq, Show) -- | We're either connected or we're not. data ConnectionStatus = Connected | Disconnected deriving (Eq) -- | An entry in a tabbed window corresponding to a tab and its content. -- Parameterized over an abstract handle type ('a') for the tabs so we -- can give each a unique handle. data TabbedWindowEntry a = TabbedWindowEntry { tweValue :: a -- ^ The handle for this tab. , tweRender :: a -> ChatState -> Widget Name -- ^ The rendering function to use when this tab -- is selected. , tweHandleEvent :: a -> Vty.Event -> MH () -- ^ The event-handling function to use when this -- tab is selected. , tweTitle :: a -> Bool -> T.Text -- ^ Title function for this tab, with a boolean -- indicating whether this is the current tab. , tweShowHandler :: a -> MH () -- ^ A handler to be invoked when this tab is -- shown. } -- | The definition of a tabbed window. Note that this does not track -- the *state* of the window; it merely provides a collection of tab -- window entries (see above). To track the state of a tabbed window, -- use a TabbedWindow. -- -- Parameterized over an abstract handle type ('a') for the tabs so we -- can give each a unique handle. data TabbedWindowTemplate a = TabbedWindowTemplate { twtEntries :: [TabbedWindowEntry a] -- ^ The entries in tabbed windows with this -- structure. , twtTitle :: a -> Widget Name -- ^ The title-rendering function for this kind -- of tabbed window. } -- | An instantiated tab window. This is based on a template and tracks -- the state of the tabbed window (current tab). -- -- Parameterized over an abstract handle type ('a') for the tabs so we -- can give each a unique handle. data TabbedWindow a = TabbedWindow { twValue :: a -- ^ The handle of the currently-selected tab. , twReturnMode :: Mode -- ^ The mode to return to when the tab is closed. , twTemplate :: TabbedWindowTemplate a -- ^ The template to use as a basis for rendering the -- window and handling user input. , twWindowWidth :: Int , twWindowHeight :: Int -- ^ Window dimensions } -- | Construct a new tabbed window from a template. This will raise an -- exception if the initially-selected tab does not exist in the window -- template, or if the window template has any duplicated tab handles. -- -- Note that the caller is responsible for determining whether to call -- the initially-selected tab's on-show handler. tabbedWindow :: (Show a, Eq a) => a -- ^ The handle corresponding to the tab that should be -- selected initially. -> TabbedWindowTemplate a -- ^ The template for the window to construct. -> Mode -- ^ When the window is closed, return to this application -- mode. -> (Int, Int) -- ^ The window dimensions (width, height). -> TabbedWindow a tabbedWindow initialVal t retMode (width, height) = let handles = tweValue <$> twtEntries t in if | null handles -> error "BUG: tabbed window template must provide at least one entry" | length handles /= length (nub handles) -> error "BUG: tabbed window should have one entry per handle" | not (initialVal `elem` handles) -> error $ "BUG: tabbed window handle " <> show initialVal <> " not present in template" | otherwise -> TabbedWindow { twTemplate = t , twValue = initialVal , twReturnMode = retMode , twWindowWidth = width , twWindowHeight = height } -- | Get the currently-selected tab entry for a tabbed window. Raise -- an exception if the window's selected tab handle is not found in its -- template (which is a bug in the tabbed window infrastructure). getCurrentTabbedWindowEntry :: (Show a, Eq a) => TabbedWindow a -> TabbedWindowEntry a getCurrentTabbedWindowEntry w = lookupTabbedWindowEntry (twValue w) w -- | Run the on-show handler for the window tab entry with the specified -- handle. runTabShowHandlerFor :: (Eq a, Show a) => a -> TabbedWindow a -> MH () runTabShowHandlerFor handle w = do let entry = lookupTabbedWindowEntry handle w tweShowHandler entry handle -- | Look up a tabbed window entry by handle. Raises an exception if no -- such entry exists. lookupTabbedWindowEntry :: (Eq a, Show a) => a -> TabbedWindow a -> TabbedWindowEntry a lookupTabbedWindowEntry handle w = let matchesVal e = tweValue e == handle in case filter matchesVal (twtEntries $ twTemplate w) of [e] -> e _ -> error $ "BUG: tabbed window entry for " <> show (twValue w) <> " should have matched a single entry" -- | Switch a tabbed window's selected tab to its next tab, cycling back -- to the first tab if the last tab is the selected tab. This also -- invokes the on-show handler for the newly-selected tab. -- -- Note that this does nothing if the window has only one tab. tabbedWindowNextTab :: (Show a, Eq a) => TabbedWindow a -> MH (TabbedWindow a) tabbedWindowNextTab w | length (twtEntries $ twTemplate w) == 1 = return w tabbedWindowNextTab w = do let curIdx = case elemIndex (tweValue curEntry) allHandles of Nothing -> error $ "BUG: tabbedWindowNextTab: could not find " <> "current handle in handle list" Just i -> i nextIdx = if curIdx == length allHandles - 1 then 0 else curIdx + 1 newHandle = allHandles !! nextIdx allHandles = tweValue <$> twtEntries (twTemplate w) curEntry = getCurrentTabbedWindowEntry w newWin = w { twValue = newHandle } runTabShowHandlerFor newHandle newWin return newWin -- | Switch a tabbed window's selected tab to its previous tab, cycling -- to the last tab if the first tab is the selected tab. This also -- invokes the on-show handler for the newly-selected tab. -- -- Note that this does nothing if the window has only one tab. tabbedWindowPreviousTab :: (Show a, Eq a) => TabbedWindow a -> MH (TabbedWindow a) tabbedWindowPreviousTab w | length (twtEntries $ twTemplate w) == 1 = return w tabbedWindowPreviousTab w = do let curIdx = case elemIndex (tweValue curEntry) allHandles of Nothing -> error $ "BUG: tabbedWindowPreviousTab: could not find " <> "current handle in handle list" Just i -> i nextIdx = if curIdx == 0 then length allHandles - 1 else curIdx - 1 newHandle = allHandles !! nextIdx allHandles = tweValue <$> twtEntries (twTemplate w) curEntry = getCurrentTabbedWindowEntry w newWin = w { twValue = newHandle } runTabShowHandlerFor newHandle newWin return newWin 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) -- | 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. } -- | 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. , _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. , _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. , _tsEditState :: ChatEditState -- ^ The state of the input box used for composing and -- editing messages and commands. , _tsMessageSelect :: MessageSelectState -- ^ The state of message selection mode. , _tsTeam :: Team -- ^ The team data. , _tsChannelSelectState :: ChannelSelectState -- ^ The state of the user's input and selection for -- channel selection mode. , _tsUrlList :: List Name (Int, LinkChoice) -- ^ The URL list used to show URLs drawn from messages in -- a channel. , _tsViewedMessage :: Maybe (Message, TabbedWindow 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.). , _tsPostListOverlay :: PostListOverlayState -- ^ The state of the post list overlay. , _tsUserListOverlay :: ListOverlayState UserInfo UserSearchScope -- ^ The state of the user list overlay. , _tsChannelListOverlay :: ListOverlayState Channel ChannelSearchScope -- ^ The state of the user list overlay. , _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. , _tsMode :: Mode -- ^ The current application mode when viewing this team. -- This is used to dispatch to different rendering and -- event handling routines. , _tsReactionEmojiListOverlay :: ListOverlayState (Bool, T.Text) () -- ^ The state of the reaction emoji list overlay. , _tsThemeListOverlay :: ListOverlayState InternalTheme () -- ^ The state of the theme list overlay. , _tsSaveAttachmentDialog :: SaveAttachmentDialogState -- ^ The state for the interactive attachment-saving -- editor window. , _tsChannelListSorting :: ChannelListSorting -- ^ How to sort channels in this team's channel list -- groups } -- | 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) } -- | The state of the attachment path window. data SaveAttachmentDialogState = SaveAttachmentDialogState { _attachmentPathEditor :: Editor T.Text Name -- ^ The attachment path editor state. , _attachmentPathDialogFocus :: FocusRing Name -- ^ The window focus state (editor/buttons) } sortTeams :: [Team] -> [Team] sortTeams = 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] mkTeamZipper :: HM.HashMap TeamId TeamState -> Z.Zipper () TeamId mkTeamZipper m = let sortedTeams = sortTeams $ _tsTeam <$> HM.elems m in mkTeamZipperFromIds $ teamId <$> sortedTeams mkTeamZipperFromIds :: [TeamId] -> Z.Zipper () TeamId mkTeamZipperFromIds tIds = Z.fromList [((), tIds)] teamZipperIds :: Z.Zipper () TeamId -> [TeamId] teamZipperIds = concat . fmap snd . Z.toList newTeamState :: Config -> Team -> Z.Zipper ChannelListGroup ChannelListEntry -> Maybe (Aspell, IO ()) -> TeamState newTeamState config team chanList spellChecker = let tId = teamId team in TeamState { _tsMode = Main , _tsFocus = chanList , _tsEditState = (emptyEditState tId) { _cedSpellChecker = spellChecker } , _tsTeam = team , _tsUrlList = list (UrlList tId) mempty 2 , _tsPostListOverlay = PostListOverlayState emptyDirSeq Nothing , _tsUserListOverlay = nullUserListOverlayState tId , _tsChannelListOverlay = nullChannelListOverlayState tId , _tsChannelSelectState = emptyChannelSelectState tId , _tsChannelTopicDialog = newChannelTopicDialog tId "" , _tsMessageSelect = MessageSelectState Nothing , _tsNotifyPrefs = Nothing , _tsPendingChannelChange = Nothing , _tsRecentChannel = Nothing , _tsReturnChannel = Nothing , _tsViewedMessage = Nothing , _tsThemeListOverlay = nullThemeListOverlayState tId , _tsReactionEmojiListOverlay = nullEmojiListOverlayState tId , _tsSaveAttachmentDialog = newSaveAttachmentDialog tId "" , _tsChannelListSorting = configChannelListSorting config } -- | Make a new channel topic editor window state. newChannelTopicDialog :: TeamId -> T.Text -> ChannelTopicDialogState newChannelTopicDialog tId t = ChannelTopicDialogState { _channelTopicDialogEditor = editor (ChannelTopicEditor tId) Nothing t , _channelTopicDialogFocus = focusRing [ ChannelTopicEditor tId , ChannelTopicSaveButton tId , ChannelTopicCancelButton tId ] } -- | Make a new attachment-saving editor window state. newSaveAttachmentDialog :: TeamId -> T.Text -> SaveAttachmentDialogState newSaveAttachmentDialog tId t = SaveAttachmentDialogState { _attachmentPathEditor = applyEdit Z2.gotoEOL $ editor (AttachmentPathEditor tId) (Just 1) t , _attachmentPathDialogFocus = focusRing [ AttachmentPathEditor tId , AttachmentPathSaveButton tId , AttachmentPathCancelButton tId ] } nullChannelListOverlayState :: TeamId -> ListOverlayState Channel ChannelSearchScope nullChannelListOverlayState tId = let newList rs = list (JoinChannelList tId) rs 2 in ListOverlayState { _listOverlaySearchResults = newList mempty , _listOverlaySearchInput = editor (JoinChannelListSearchInput tId) (Just 1) "" , _listOverlaySearchScope = AllChannels , _listOverlaySearching = False , _listOverlayEnterHandler = const $ return False , _listOverlayNewList = newList , _listOverlayFetchResults = const $ const $ const $ return mempty , _listOverlayRecordCount = Nothing , _listOverlayReturnMode = Main } nullThemeListOverlayState :: TeamId -> ListOverlayState InternalTheme () nullThemeListOverlayState tId = let newList rs = list (ThemeListSearchResults tId) rs 3 in ListOverlayState { _listOverlaySearchResults = newList mempty , _listOverlaySearchInput = editor (ThemeListSearchInput tId) (Just 1) "" , _listOverlaySearchScope = () , _listOverlaySearching = False , _listOverlayEnterHandler = const $ return False , _listOverlayNewList = newList , _listOverlayFetchResults = const $ const $ const $ return mempty , _listOverlayRecordCount = Nothing , _listOverlayReturnMode = Main } nullUserListOverlayState :: TeamId -> ListOverlayState UserInfo UserSearchScope nullUserListOverlayState tId = let newList rs = list (UserListSearchResults tId) rs 1 in ListOverlayState { _listOverlaySearchResults = newList mempty , _listOverlaySearchInput = editor (UserListSearchInput tId) (Just 1) "" , _listOverlaySearchScope = AllUsers Nothing , _listOverlaySearching = False , _listOverlayEnterHandler = const $ return False , _listOverlayNewList = newList , _listOverlayFetchResults = const $ const $ const $ return mempty , _listOverlayRecordCount = Nothing , _listOverlayReturnMode = Main } nullEmojiListOverlayState :: TeamId -> ListOverlayState (Bool, T.Text) () nullEmojiListOverlayState tId = let newList rs = list (ReactionEmojiList tId) rs 1 in ListOverlayState { _listOverlaySearchResults = newList mempty , _listOverlaySearchInput = editor (ReactionEmojiListInput tId) (Just 1) "" , _listOverlaySearchScope = () , _listOverlaySearching = False , _listOverlayEnterHandler = const $ return False , _listOverlayNewList = newList , _listOverlayFetchResults = const $ const $ const $ return mempty , _listOverlayRecordCount = Nothing , _listOverlayReturnMode = MessageSelect } -- | 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 message selection mode. data MessageSelectState = MessageSelectState { selectMessageId :: Maybe MessageId } -- | The state of the post list overlay. data PostListOverlayState = PostListOverlayState { _postListPosts :: Messages , _postListSelected :: Maybe PostId } data InternalTheme = InternalTheme { internalThemeName :: Text , internalTheme :: Theme , internalThemeDesc :: Text } -- | The state of the search result list overlay. Type 'a' is the type -- of data in the list. Type 'b' is the search scope type. data ListOverlayState a b = ListOverlayState { _listOverlaySearchResults :: List Name a -- ^ The list of search results currently shown in -- the overlay. , _listOverlaySearchInput :: Editor Text Name -- ^ The editor for the overlay's search input. , _listOverlaySearchScope :: b -- ^ The overlay's current search scope. , _listOverlaySearching :: Bool -- ^ Whether a search is in progress (i.e. whether -- we are currently awaiting a response from a -- search query to the server). , _listOverlayEnterHandler :: a -> MH Bool -- ^ The handler to invoke on the selected element -- when the user presses Enter. , _listOverlayNewList :: Vec.Vector a -> List Name a -- ^ The function to build a new brick List from a -- vector of search results. , _listOverlayFetchResults :: b -> Session -> Text -> IO (Vec.Vector a) -- ^ The function to call to issue a search query -- to the server. , _listOverlayRecordCount :: Maybe Int -- ^ The total number of available records, if known. , _listOverlayReturnMode :: Mode -- ^ The mode to return to when the window closes. } -- | The scope for searching for users in a user list overlay. 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 { mhCurrentState :: ChatState , mhNextAction :: ChatState -> EventM Name (Next ChatState) , 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)) 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 'MM' computation, choosing whether to continue or halt based -- on the resulting runMHEvent :: ChatState -> MH () -> EventM Name (Next ChatState) runMHEvent st (MH mote) = do let mhSt = MHState { mhCurrentState = st , mhNextAction = Brick.continue , mhUsersToFetch = [] , mhPendingStatusList = Nothing } ((), st') <- St.runStateT (R.runReaderT mote Nothing) mhSt (mhNextAction st') (mhCurrentState st') 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 a -> MH a mh = MH . R.lift . St.lift generateUUID :: MH UUID generateUUID = liftIO generateUUID_IO generateUUID_IO :: IO UUID generateUUID_IO = randomIO mhHandleEventLensed :: Lens' ChatState b -> (e -> b -> EventM Name b) -> e -> MH () mhHandleEventLensed ln f event = MH $ do s <- St.get let st = mhCurrentState s n <- R.lift $ St.lift $ f event (st ^. ln) St.put (s { mhCurrentState = st & ln .~ n }) mhHandleEventLensed' :: Lens' ChatState b -> (b -> EventM Name b) -> MH () mhHandleEventLensed' ln f = MH $ do s <- St.get let st = mhCurrentState s n <- R.lift $ St.lift $ f (st ^. ln) St.put (s { mhCurrentState = st & ln .~ n }) mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH () mhSuspendAndResume mote = MH $ do s <- St.get St.put $ s { mhNextAction = \ _ -> Brick.suspendAndResume (mote $ mhCurrentState s) } mhContinueWithoutRedraw :: MH () mhContinueWithoutRedraw = MH $ do s <- St.get St.put $ s { mhNextAction = \ _ -> Brick.continueWithoutRedraw (mhCurrentState s) } -- | This will request that after this computation finishes the -- application should exit requestQuit :: MH () requestQuit = MH $ do s <- St.get St.put $ s { mhNextAction = 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 MHF.MonadFail MH where fail = MH . MHF.fail instance Monad MH where return = pure MH x >>= f = MH (x >>= \ x' -> fromMH (f x')) -- We want to pretend that the state is only the ChatState, rather -- than the ChatState and the Brick continuation instance St.MonadState ChatState MH where get = mhCurrentState `fmap` MH St.get put st = MH $ do s <- St.get St.put $ s { mhCurrentState = st } 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 ''ChatEditState makeLenses ''AutocompleteState makeLenses ''PostListOverlayState makeLenses ''ListOverlayState makeLenses ''ChannelSelectState makeLenses ''UserPreferences makeLenses ''ConnectionInfo makeLenses ''ChannelTopicDialogState makeLenses ''SaveAttachmentDialogState Brick.suffixLenses ''Config applyTeamOrderPref :: Maybe [TeamId] -> ChatState -> ChatState applyTeamOrderPref Nothing st = st applyTeamOrderPref (Just prefTIds) st = let teams = _csTeams st ourTids = HM.keys teams tIds = filter (`elem` ourTids) prefTIds curTId = st^.csCurrentTeamId unmentioned = filter (not . wasMentioned) $ HM.elems teams wasMentioned ts = (teamId $ _tsTeam ts) `elem` tIds zipperTids = tIds <> (teamId <$> sortTeams (_tsTeam <$> unmentioned)) in st { _csTeamZipper = (Z.findRight ((== curTId) . Just) $ mkTeamZipperFromIds zipperTids) } refreshTeamZipper :: MH () refreshTeamZipper = do tidOrder <- use (csResources.crUserPreferences.userPrefTeamOrder) St.modify (applyTeamOrderPref tidOrder) applyTeamOrder :: [TeamId] -> MH () applyTeamOrder tIds = St.modify (applyTeamOrderPref $ Just tIds) newState :: StartupStateInfo -> ChatState newState (StartupStateInfo {..}) = let config = _crConfiguration startupStateResources in applyTeamOrderPref (_userPrefTeamOrder $ _crUserPreferences startupStateResources) $ ChatState { _csResources = startupStateResources , _csLastMouseDownEvent = Nothing , _csVerbatimTruncateSetting = configTruncateVerbatimBlocks config , _csTeamZipper = Z.findRight (== startupStateInitialTeam) $ mkTeamZipper 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 unsafeCedFileBrowser :: Lens' ChatEditState (FB.FileBrowser Name) unsafeCedFileBrowser = lens (\st -> st^.cedFileBrowser ^?! _Just) (\st t -> st & cedFileBrowser .~ Just t) getSession :: MH Session getSession = use (csResources.crSession) getResourceSession :: ChatResources -> Session getResourceSession = _crSession whenMode :: TeamId -> Mode -> MH () -> MH () whenMode tId m act = do curMode <- use (csTeam(tId).tsMode) when (curMode == m) act setMode :: TeamId -> Mode -> MH () setMode tId m = do csTeam(tId).tsMode .= m mh invalidateCache setMode' :: TeamId -> Mode -> ChatState -> ChatState setMode' tId m = csTeam(tId).tsMode .~ m resetSpellCheckTimer :: ChatEditState -> IO () resetSpellCheckTimer s = case s^.cedSpellChecker of Nothing -> return () Just (_, reset) -> reset -- ** Utility Lenses csCurrentChannelId :: TeamId -> SimpleGetter ChatState (Maybe ChannelId) csCurrentChannelId tId = csTeam(tId).tsFocus.to Z.focus.to (fmap channelListEntryChannelId) 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 csTeam :: TeamId -> Lens' ChatState TeamState csTeam tId = lens (\ st -> st ^. csTeams . at tId ^?! _Just) (\ st t -> st & csTeams . at tId .~ Just t) 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 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 -- ** '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 :: TeamId -> MH () resetAutocomplete tId = do csTeam(tId).tsEditState.cedAutocomplete .= Nothing csTeam(tId).tsEditState.cedAutocompletePending .= 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 (ChannelMessages 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