{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Types ( ConnectionStatus(..) , HelpTopic(..) , MessageSelectState(..) , ProgramOutput(..) , MHEvent(..) , InternalEvent(..) , Name(..) , ChannelSelectMatch(..) , StartupStateInfo(..) , MHError(..) , AttachmentData(..) , CPUUsagePolicy(..) , OpenInBrowser(..) , ConnectionInfo(..) , SidebarUpdate(..) , PendingChannelChange(..) , clearChannelUnreadStatus , ChannelListEntry(..) , channelListEntryChannelId , channelListEntryUserId , userIdsFromZipper , entryIsDMEntry , ciHostname , ciPort , ciUsername , ciPassword , Config(..) , HelpScreen(..) , PasswordSource(..) , MatchType(..) , Mode(..) , ChannelSelectPattern(..) , PostListContents(..) , AuthenticationException(..) , BackgroundInfo(..) , RequestChan , mkChannelZipperList , ChannelListGroup(..) , trimChannelSigil , ChannelSelectState(..) , channelSelectMatches , channelSelectInput , emptyChannelSelectState , ChatState , newState , csResources , csFocus , csCurrentChannel , csCurrentChannelId , csUrlList , csShowMessagePreview , csShowChannelList , csPostMap , csRecentChannel , csPostListOverlay , csUserListOverlay , csMyTeam , csMessageSelect , csJoinChannelList , csConnectionStatus , csWorkerIsBusy , csChannel , csChannels , csChannelSelectState , csEditState , csClientConfig , csPendingChannelChange , csViewedMessage , timeZone , whenMode , setMode , setMode' , appMode , ChatEditState , emptyEditState , cedAttachmentList , cedFileBrowser , cedYankBuffer , cedSpellChecker , cedMisspellings , cedEditMode , cedEphemeral , cedEditor , cedInputHistory , cedAutocomplete , cedAutocompletePending , AutocompleteState(..) , acPreviousSearchString , acCompletionList , acListElementType , acCachedResponses , AutocompleteAlternative(..) , autocompleteAlternativeReplacement , PostListOverlayState , postListSelected , postListPosts , UserSearchScope(..) , UserListOverlayState , userListSearchResults , userListSearchInput , userListSearchScope , userListSearching , userListRequestingMore , userListHasAllResults , userListEnterHandler , listFromUserSearchResults , getUsers , ChatResources(..) , crUserPreferences , crEventQueue , crTheme , crStatusUpdateChan , crSubprocessLog , crWebsocketActionChan , crWebsocketThreadId , crRequestQueue , crFlaggedPosts , crConn , crConfiguration , crSyntaxMap , crLogManager , getSession , getResourceSession , UserPreferences(UserPreferences) , userPrefShowJoinLeave , userPrefFlaggedPostList , userPrefGroupChannelPrefs , userPrefDirectChannelPrefs , userPrefTeammateNameDisplayMode , dmChannelShowPreference , groupChannelShowPreference , defaultUserPreferences , setUserPreferences , WebsocketAction(..) , Cmd(..) , commandName , CmdArgs(..) , MH , runMHEvent , mh , generateUUID , generateUUID_IO , mhSuspendAndResume , mhHandleEventLensed , St.gets , mhError , mhLog , mhGetIOLogger , LogContext(..) , withLogContext , withLogContextChannelId , getLogContext , LogMessage(..) , LogCommand(..) , LogCategory(..) , LogManager(..) , startLoggingToFile , stopLoggingToFile , requestLogSnapshot , requestLogDestination , sendLogMessage , requestQuit , getMessageForPostId , getParentMessage , resetSpellCheckTimer , withChannel , withChannelOrDefault , userList , resetAutocomplete , hasUnread , hasUnread' , isMine , setUserStatus , myUser , myUserId , myTeamId , usernameForUserId , userByUsername , userByNickname , channelIdByChannelName , channelIdByUsername , channelByName , userById , allUserIds , addNewUser , useNickname , useNickname' , displayNameForUserId , displayNameForUser , raiseInternalEvent , getNewMessageCutoff , getEditedMessageCutoff , normalChannelSigil , HighlightSet(..) , UserSet , ChannelSet , getHighlightSet , module Types.Channels , module Types.Messages , module Types.Posts , module Types.Users ) where import Prelude () import Prelude.MH import qualified Brick import Brick ( EventM, Next ) import Brick.Main ( invalidateCache, invalidateCacheEntry ) import Brick.AttrMap ( AttrMap ) import Brick.BChan import Brick.Widgets.Edit ( Editor, editor ) 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.State as St import qualified Control.Monad.Reader as R import qualified Data.ByteString as BS import qualified Data.Foldable as F import Data.Ord ( comparing ) import qualified Data.HashMap.Strict as HM import Data.List ( sortBy ) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Time.Clock ( UTCTime, getCurrentTime, addUTCTime ) import Data.UUID ( UUID ) import qualified Data.Vector as Vec import Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=) , (%=), (^?), (.~) , _Just, Traversal', preuse, 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 ) import InputHistory import Types.Common import Types.Channels import Types.DirectionalSeq ( emptyDirSeq ) import Types.KeyEvents import Types.Messages import Types.Posts import Types.Users import Zipper ( Zipper, toList, fromList, unsafeFocus ) -- * Configuration -- | 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) -- | The type of channel list group headings. data ChannelListGroup = ChannelGroupPublicChannels | ChannelGroupDirectMessages deriving (Eq) -- | The type of channel list entries. data ChannelListEntry = CLChannel ChannelId -- ^ A non-DM entry | CLUserDM ChannelId UserId -- ^ A single-user DM entry | CLGroupDM ChannelId -- ^ A multi-user DM entry deriving (Eq, Show) -- | 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. , configPass :: Maybe PasswordSource -- ^ The password 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. , 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. , configActivityBell :: Bool -- ^ Whether to ring the terminal bell on activity. , 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. , 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. , 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. , configShowTypingIndicator :: Bool -- ^ Whether to show the typing indicator for other users, -- and 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. } 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 , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode } hasUnread :: ChatState -> ChannelId -> Bool hasUnread st cId = fromMaybe False $ hasUnread' <$> findChannelById cId (_csChannels st) hasUnread' :: ClientChannel -> Bool hasUnread' chan = fromMaybe False $ do let info = _ccInfo chan lastViewTime <- _cdViewed info return $ ((_cdUpdated info) > lastViewTime) || (isJust $ _cdEditedMessageThreshold info) mkChannelZipperList :: UTCTime -> Config -> Maybe ClientConfig -> UserPreferences -> ClientChannels -> Users -> [(ChannelListGroup, [ChannelListEntry])] mkChannelZipperList now config cconfig prefs cs us = [ (ChannelGroupPublicChannels, getNonDMChannelIdsInOrder cs) , (ChannelGroupDirectMessages, getDMChannelsInOrder now config cconfig prefs us cs) ] getNonDMChannelIdsInOrder :: ClientChannels -> [ChannelListEntry] getNonDMChannelIdsInOrder cs = let matches (_, info) = info^.ccInfo.cdType `notElem` [Direct, Group] in fmap (CLChannel . fst) $ sortBy (comparing ((^.ccInfo.cdName) . snd)) $ filteredChannels matches cs getDMChannelsInOrder :: UTCTime -> Config -> Maybe ClientConfig -> UserPreferences -> Users -> ClientChannels -> [ChannelListEntry] getDMChannelsInOrder now config cconfig prefs us cs = let oneOnOneDmChans = getDMChannels now config cconfig prefs us cs groupChans = getGroupDMChannels now config prefs cs allDmChans = groupChans <> oneOnOneDmChans sorter (u1, n1, _) (u2, n2, _) = if u1 == u2 then compare n1 n2 else if u1 && not u2 then LT else GT sorted = sortBy sorter allDmChans third (_, _, c) = c in third <$> sorted 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 getGroupDMChannels :: UTCTime -> Config -> UserPreferences -> ClientChannels -> [(Bool, T.Text, ChannelListEntry)] getGroupDMChannels now config prefs cs = let matches (_, info) = info^.ccInfo.cdType == Group && groupChannelShouldAppear now config prefs info in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdName, CLGroupDM cId)) $ filteredChannels matches cs getDMChannels :: UTCTime -> Config -> Maybe ClientConfig -> UserPreferences -> Users -> ClientChannels -> [(Bool, T.Text, ChannelListEntry)] getDMChannels 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 (hasUnread' c, displayNameForUser u cconfig prefs, CLUserDM cId uId) else Nothing in mappingWithUserInfo -- Always show a DM channel if it has unread activity. -- -- 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 Just uId = c^.ccInfo.cdDMUserId in 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 ] 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 in if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) then True else case groupChannelShowPreference prefs (c^.ccInfo.cdChannelId) 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) -- * 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 | ChannelList | HelpViewport | HelpText | ScriptHelpText | ThemeHelpText | SyntaxHighlightHelpText | KeybindingHelpText | ChannelSelectString | CompletionAlternatives | CompletionList | JoinChannelList | UrlList | MessagePreviewViewport | UserListSearchInput | UserListSearchResults | ViewMessageArea | ChannelSidebar | ChannelSelectInput | AttachmentList | AttachmentFileBrowser deriving (Eq, Show, Ord) -- | 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 | 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. data ConnectionInfo = ConnectionInfo { _ciHostname :: Text , _ciPort :: Int , _ciUsername :: Text , _ciPassword :: Text } -- | 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) -- Sigils normalChannelSigil :: Text normalChannelSigil = "~" -- ** 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) 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 , programStdoutExpected :: Bool , programStderr :: String , programExitCode :: ExitCode } defaultUserPreferences :: UserPreferences defaultUserPreferences = UserPreferences { _userPrefShowJoinLeave = True , _userPrefFlaggedPostList = mempty , _userPrefGroupChannelPrefs = mempty , _userPrefDirectChannelPrefs = mempty , _userPrefTeammateNameDisplayMode = 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) } | 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 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 (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 :: BChan MHEvent , _crSubprocessLog :: STM.TChan ProgramOutput , _crWebsocketActionChan :: STM.TChan WebsocketAction , _crTheme :: AttrMap , _crStatusUpdateChan :: STM.TChan (Zipper ChannelListGroup ChannelListEntry) , _crConfiguration :: Config , _crFlaggedPosts :: Set PostId , _crUserPreferences :: UserPreferences , _crSyntaxMap :: SyntaxMap , _crLogManager :: LogManager } data AutocompleteAlternative = UserCompletion User Bool -- ^ User, plus whether the user is in the channel that triggered -- the autocomplete | ChannelCompletion Bool Channel -- ^ Channel, plus whether the user is a member of the channel | SyntaxCompletion Text -- ^ Name of a skylighting syntax definition | CommandCompletion Text Text Text -- ^ Name of a slash command, argspec, and description autocompleteAlternativeReplacement :: AutocompleteAlternative -> Text autocompleteAlternativeReplacement (UserCompletion u _) = userSigil <> userUsername u autocompleteAlternativeReplacement (ChannelCompletion _ c) = normalChannelSigil <> (sanitizeUserText $ channelName c) autocompleteAlternativeReplacement (SyntaxCompletion t) = "```" <> t autocompleteAlternativeReplacement (CommandCompletion t _ _) = "/" <> t 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 , _acListElementType :: Text -- ^ The label (plural noun, e.g. "Users") used to -- display the result list to the user , _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 , _cedInputHistory :: 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. , _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 :: FB.FileBrowser Name -- ^ The browser for selecting attachment files. } -- | 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 :: InputHistory -> Maybe (Aspell, IO ()) -> IO ChatEditState emptyEditState hist sp = do browser <- FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser Nothing return ChatEditState { _cedEditor = editor MessageInput Nothing "" , _cedEphemeral = defaultEphemeralEditState , _cedInputHistory = hist , _cedEditMode = NewPost , _cedYankBuffer = "" , _cedSpellChecker = sp , _cedMisspellings = mempty , _cedAutocomplete = Nothing , _cedAutocompletePending = Nothing , _cedAttachmentList = list AttachmentList mempty 1 , _cedFileBrowser = browser } -- | 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) -- | Help topics data HelpTopic = HelpTopic { helpTopicName :: Text , helpTopicDescription :: Text , helpTopicScreen :: HelpScreen , helpTopicViewportName :: Name } deriving (Eq) -- | Mode type for the current contents of the post list overlay data PostListContents = PostListFlagged | PostListSearch Text Bool -- for the query and search status deriving (Eq) -- | The 'Mode' represents the current dominant UI activity data Mode = Main | ShowHelp HelpTopic | ChannelSelect | UrlSelect | LeaveChannelConfirm | DeleteChannelConfirm | JoinChannel | MessageSelect | MessageSelectDeleteConfirm | PostListOverlay PostListContents | UserListOverlay | ViewMessage | ManageAttachments | ManageAttachmentsBrowseFiles deriving (Eq) -- | We're either connected or we're not. data ConnectionStatus = Connected | Disconnected deriving (Eq) -- | This is the giant bundle of fields that represents the current -- state of our application at any given time. Some of this should be -- broken out further, but hasn't yet been. data ChatState = ChatState { _csResources :: ChatResources -- ^ Global application-wide resources that don't change -- much. , _csFocus :: Zipper ChannelListGroup ChannelListEntry -- ^ The channel sidebar zipper that tracks which channel -- is selected. , _csMe :: User -- ^ The authenticated user. , _csMyTeam :: Team -- ^ The active team of the authenticated user. , _csChannels :: ClientChannels -- ^ The channels that we are showing, including their -- message lists. , _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. , _csEditState :: ChatEditState -- ^ The state of the input box used for composing and -- editing messages and commands. , _csMode :: Mode -- ^ The current application mode. This is used to -- dispatch to different rendering and event handling -- routines. , _csShowMessagePreview :: Bool -- ^ Whether to show the message preview area. , _csShowChannelList :: Bool -- ^ Whether to show the channe list. , _csChannelSelectState :: ChannelSelectState -- ^ The state of the user's input and selection for -- channel selection mode. , _csRecentChannel :: Maybe ChannelId -- ^ The most recently-selected channel, if any. , _csUrlList :: List Name LinkChoice -- ^ The URL list used to show URLs drawn from messages in -- a channel. , _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. , _csJoinChannelList :: Maybe (List Name Channel) -- ^ The list of channels presented in the channel join -- window. , _csMessageSelect :: MessageSelectState -- ^ The state of message selection mode. , _csPostListOverlay :: PostListOverlayState -- ^ The state of the post list overlay. , _csUserListOverlay :: UserListOverlayState -- ^ The state of the user list overlay. , _csClientConfig :: Maybe ClientConfig -- ^ The Mattermost client configuration, as we understand it. , _csPendingChannelChange :: 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. , _csViewedMessage :: Maybe Message -- ^ Set when the ViewMessage mode is active. The message -- being viewed. } data PendingChannelChange = ChangeByChannelId ChannelId | ChangeByUserId UserId deriving (Eq, Show) -- | Startup state information that is constructed prior to building a -- ChatState. data StartupStateInfo = StartupStateInfo { startupStateResources :: ChatResources , startupStateChannelZipper :: Zipper ChannelListGroup ChannelListEntry , startupStateConnectedUser :: User , startupStateTeam :: Team , startupStateTimeZone :: TimeZoneSeries , startupStateInitialHistory :: InputHistory , startupStateSpellChecker :: Maybe (Aspell, IO ()) } newState :: StartupStateInfo -> IO ChatState newState (StartupStateInfo {..}) = do editState <- emptyEditState startupStateInitialHistory startupStateSpellChecker return ChatState { _csResources = startupStateResources , _csFocus = startupStateChannelZipper , _csMe = startupStateConnectedUser , _csMyTeam = startupStateTeam , _csChannels = noChannels , _csPostMap = HM.empty , _csUsers = noUsers , _timeZone = startupStateTimeZone , _csEditState = editState , _csMode = Main , _csShowMessagePreview = configShowMessagePreview $ _crConfiguration startupStateResources , _csShowChannelList = configShowChannelList $ _crConfiguration startupStateResources , _csChannelSelectState = emptyChannelSelectState , _csRecentChannel = Nothing , _csUrlList = list UrlList mempty 2 , _csConnectionStatus = Connected , _csWorkerIsBusy = Nothing , _csJoinChannelList = Nothing , _csMessageSelect = MessageSelectState Nothing , _csPostListOverlay = PostListOverlayState emptyDirSeq Nothing , _csUserListOverlay = nullUserListOverlayState , _csClientConfig = Nothing , _csPendingChannelChange = Nothing , _csViewedMessage = Nothing } nullUserListOverlayState :: UserListOverlayState nullUserListOverlayState = UserListOverlayState { _userListSearchResults = listFromUserSearchResults mempty , _userListSearchInput = editor UserListSearchInput (Just 1) "" , _userListSearchScope = AllUsers Nothing , _userListSearching = False , _userListRequestingMore = False , _userListHasAllResults = False , _userListEnterHandler = const $ return False } listFromUserSearchResults :: Vec.Vector UserInfo -> List Name UserInfo listFromUserSearchResults rs = -- NB: The item height here needs to actually match the UI drawing -- in Draw.UserListOverlay. list UserListSearchResults rs 1 -- | The state of channel selection mode. data ChannelSelectState = ChannelSelectState { _channelSelectInput :: Editor Text Name , _channelSelectMatches :: Zipper ChannelListGroup ChannelSelectMatch } emptyChannelSelectState :: ChannelSelectState emptyChannelSelectState = ChannelSelectState { _channelSelectInput = editor ChannelSelectInput (Just 1) "" , _channelSelectMatches = 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 } -- | The state of the user list overlay. data UserListOverlayState = UserListOverlayState { _userListSearchResults :: List Name UserInfo , _userListSearchInput :: Editor Text Name , _userListSearchScope :: UserSearchScope , _userListSearching :: Bool , _userListRequestingMore :: Bool , _userListHasAllResults :: Bool , _userListEnterHandler :: UserInfo -> MH Bool } -- | The scope for searching for users in a user list overlay. data UserSearchScope = ChannelMembers ChannelId TeamId | ChannelNonMembers ChannelId TeamId | AllUsers (Maybe TeamId) -- | 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 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 (ChatState, ChatState -> EventM Name (Next ChatState)) (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 $ \cat msg -> do now <- liftIO getCurrentTime let lm = LogMessage { logMessageText = msg , logMessageContext = ctx , logMessageCategory = cat , logMessageTimestamp = now } liftIO $ 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 ((), (st', rs)) <- St.runStateT (R.runReaderT mote Nothing) (st, Brick.continue) rs st' -- | 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 (st, b) <- St.get n <- R.lift $ St.lift $ f event (st ^. ln) St.put (st & ln .~ n , b) mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH () mhSuspendAndResume mote = MH $ do (st, _) <- St.get St.put (st, \ _ -> Brick.suspendAndResume (mote st)) -- | This will request that after this computation finishes the -- application should exit requestQuit :: MH () requestQuit = MH $ do (st, _) <- St.get St.put (st, 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 x = MH (return x) 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 = fst `fmap` MH St.get put st = MH $ do (_, c) <- St.get St.put (st, c) 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 | 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) | 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 | AsyncErrEvent SomeException -- ^ For errors that arise in the course of async IO operations deriving (Show) -- ** Application State Lenses makeLenses ''ChatResources makeLenses ''ChatState makeLenses ''ChatEditState makeLenses ''AutocompleteState makeLenses ''PostListOverlayState makeLenses ''UserListOverlayState makeLenses ''ChannelSelectState makeLenses ''UserPreferences makeLenses ''ConnectionInfo getSession :: MH Session getSession = use (csResources.crSession) getResourceSession :: ChatResources -> Session getResourceSession = _crSession whenMode :: Mode -> MH () -> MH () whenMode m act = do curMode <- use csMode when (curMode == m) act setMode :: Mode -> MH () setMode m = do csMode .= m mh invalidateCache setMode' :: Mode -> ChatState -> ChatState setMode' m = csMode .~ m appMode :: ChatState -> Mode appMode = _csMode resetSpellCheckTimer :: ChatEditState -> IO () resetSpellCheckTimer s = case s^.cedSpellChecker of Nothing -> return () Just (_, reset) -> reset -- ** Utility Lenses csCurrentChannelId :: SimpleGetter ChatState ChannelId csCurrentChannelId = csFocus.to unsafeFocus.to channelListEntryChannelId channelListEntryChannelId :: ChannelListEntry -> ChannelId channelListEntryChannelId (CLChannel cId) = cId channelListEntryChannelId (CLUserDM cId _) = cId channelListEntryChannelId (CLGroupDM cId) = cId channelListEntryUserId :: ChannelListEntry -> Maybe UserId channelListEntryUserId (CLUserDM _ uId) = Just uId channelListEntryUserId _ = Nothing userIdsFromZipper :: Zipper ChannelListGroup ChannelListEntry -> [UserId] userIdsFromZipper z = concat $ (catMaybes . fmap channelListEntryUserId . snd) <$> Zipper.toList z entryIsDMEntry :: ChannelListEntry -> Bool entryIsDMEntry (CLUserDM {}) = True entryIsDMEntry (CLGroupDM {}) = True entryIsDMEntry (CLChannel {}) = False csCurrentChannel :: Lens' ChatState ClientChannel csCurrentChannel = lens (\ st -> findChannelById (st^.csCurrentChannelId) (st^.csChannels) ^?! _Just) (\ st n -> st & csChannels %~ addChannel (st^.csCurrentChannelId) n) 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) St.liftIO $ writeBChan queue (IEvent ev) -- | 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 = (UserI $ myUserId st) == msg^.mUser 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 setUserStatus :: UserId -> Text -> MH () setUserStatus uId t = do csUsers %= modifyUserById uId (uiStatus .~ statusFromText t) mh $ invalidateCacheEntry ChannelSidebar 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 :: Text -> ChatState -> Maybe ChannelId channelIdByChannelName name st = let matches (_, cc) = cc^.ccInfo.cdName == (trimChannelSigil name) 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) channelByName :: Text -> ChatState -> Maybe ClientChannel channelByName n st = do cId <- channelIdByChannelName n st findChannelById cId (st^.csChannels) 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 :: MH () resetAutocomplete = do csEditState.cedAutocomplete .= Nothing csEditState.cedAutocompletePending .= Nothing -- * Slash Commands -- | The 'CmdArgs' type represents the arguments to a slash-command; the -- type parameter represents the argument structure. data CmdArgs :: * -> * where NoArg :: CmdArgs () LineArg :: Text -> CmdArgs Text 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 myTeamId :: ChatState -> TeamId myTeamId st = st ^. csMyTeam . teamIdL myUser :: ChatState -> User myUser st = 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 } getHighlightSet :: ChatState -> HighlightSet getHighlightSet st = HighlightSet { hUserSet = getUsernameSet $ st^.csUsers , hChannelSet = getChannelNameSet $ st^.csChannels , hSyntaxMap = st^.csResources.crSyntaxMap } 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) data OpenInBrowser = OpenLinkChoice LinkChoice | OpenLocalFile FilePath deriving (Eq, Show)