{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Matterhorn.Types
( ConnectionStatus(..)
, HelpTopic(..)
, MessageSelectState(..)
, ProgramOutput(..)
, MHEvent(..)
, InternalEvent(..)
, Name(..)
, ChannelSelectMatch(..)
, StartupStateInfo(..)
, MHError(..)
, AttachmentData(..)
, CPUUsagePolicy(..)
, tabbedWindow
, getCurrentTabbedWindowEntry
, tabbedWindowNextTab
, tabbedWindowPreviousTab
, runTabShowHandlerFor
, getServerBaseUrl
, serverBaseUrl
, TabbedWindow(..)
, TabbedWindowEntry(..)
, TabbedWindowTemplate(..)
, ConnectionInfo(..)
, SidebarUpdate(..)
, PendingChannelChange(..)
, ViewMessageWindowTab(..)
, clearChannelUnreadStatus
, ChannelListEntry(..)
, ChannelListOrientation(..)
, channelListEntryChannelId
, channelListEntryUserId
, userIdsFromZipper
, entryIsDMEntry
, ciHostname
, ciPort
, ciUrlPath
, ciUsername
, ciPassword
, ciType
, ciAccessToken
, newChannelTopicDialog
, ChannelTopicDialogState(..)
, channelTopicDialogEditor
, channelTopicDialogFocus
, Config(..)
, HelpScreen(..)
, PasswordSource(..)
, TokenSource(..)
, MatchType(..)
, Mode(..)
, ChannelSelectPattern(..)
, PostListContents(..)
, AuthenticationException(..)
, BackgroundInfo(..)
, RequestChan
, UserFetch(..)
, writeBChan
, InternalTheme(..)
, attrNameToConfig
, mkChannelZipperList
, ChannelListGroup(..)
, channelListGroupUnread
, trimChannelSigil
, ChannelSelectState(..)
, channelSelectMatches
, channelSelectInput
, emptyChannelSelectState
, ChatState
, newState
, csChannelTopicDialog
, csChannelListOrientation
, csResources
, csFocus
, csCurrentChannel
, csCurrentChannelId
, csUrlList
, csShowMessagePreview
, csShowChannelList
, csShowExpandedChannelTopics
, csPostMap
, csRecentChannel
, csReturnChannel
, csThemeListOverlay
, csPostListOverlay
, csUserListOverlay
, csChannelListOverlay
, csReactionEmojiListOverlay
, csMyTeam
, csMessageSelect
, csConnectionStatus
, csWorkerIsBusy
, csChannel
, csChannels
, csChannelSelectState
, csEditState
, csClientConfig
, csPendingChannelChange
, csViewedMessage
, csNotifyPrefs
, csMe
, timeZone
, whenMode
, setMode
, setMode'
, appMode
, ChatEditState
, emptyEditState
, cedAttachmentList
, cedFileBrowser
, cedYankBuffer
, cedSpellChecker
, cedMisspellings
, cedEditMode
, cedEphemeral
, cedEditor
, cedInputHistory
, 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
, UserPreferences(UserPreferences)
, userPrefShowJoinLeave
, userPrefFlaggedPostList
, userPrefGroupChannelPrefs
, userPrefDirectChannelPrefs
, userPrefTeammateNameDisplayMode
, dmChannelShowPreference
, groupChannelShowPreference
, defaultUserPreferences
, setUserPreferences
, WebsocketAction(..)
, Cmd(..)
, commandName
, CmdArgs(..)
, MH
, runMHEvent
, scheduleUserFetches
, scheduleUserStatusFetches
, getScheduledUserFetches
, getScheduledUserStatusFetches
, mh
, generateUUID
, generateUUID_IO
, mhSuspendAndResume
, mhHandleEventLensed
, 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
, hasUnread
, hasUnread'
, isMine
, setUserStatus
, myUser
, myUsername
, myUserId
, myTeamId
, usernameForUserId
, userByUsername
, userByNickname
, channelIdByChannelName
, channelIdByUsername
, channelByName
, userById
, allUserIds
, addNewUser
, useNickname
, useNickname'
, displayNameForUserId
, displayNameForUser
, raiseInternalEvent
, getNewMessageCutoff
, getEditedMessageCutoff
, HighlightSet(..)
, UserSet
, ChannelSet
, getHighlightSet
, 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 )
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 )
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 qualified Data.Kind as K
import Data.Ord ( comparing )
import qualified Data.HashMap.Strict as HM
import Data.List ( sortBy, nub, elemIndex )
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import Data.Time.Clock ( getCurrentTime, addUTCTime )
import Data.UUID ( UUID )
import qualified Data.Vector as Vec
import 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, WebsocketActionResponse )
import Matterhorn.Constants ( userSigil, 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
data PasswordSource =
PasswordString Text
| PasswordCommand Text
deriving (Eq, Read, Show)
data TokenSource =
TokenString Text
| TokenCommand Text
deriving (Eq, Read, Show)
data ChannelListGroup =
ChannelGroupPublicChannels Int
| ChannelGroupPrivateChannels Int
| ChannelGroupDirectMessages Int
deriving (Eq)
channelListGroupUnread :: ChannelListGroup -> Int
channelListGroupUnread (ChannelGroupPublicChannels n) = n
channelListGroupUnread (ChannelGroupPrivateChannels n) = n
channelListGroupUnread (ChannelGroupDirectMessages n) = n
data ChannelListEntry =
CLChannel ChannelId
| CLUserDM ChannelId UserId
| CLGroupDM ChannelId
deriving (Eq, Show)
data Config =
Config { configUser :: Maybe Text
, configHost :: Maybe Text
, configTeam :: Maybe Text
, configPort :: Int
, configUrlPath :: Maybe Text
, configPass :: Maybe PasswordSource
, configToken :: Maybe TokenSource
, configTimeFormat :: Maybe Text
, configDateFormat :: Maybe Text
, configTheme :: Maybe Text
, configThemeCustomizationFile :: Maybe Text
, configSmartBacktick :: Bool
, configSmartEditing :: Bool
, configURLOpenCommand :: Maybe Text
, configURLOpenCommandInteractive :: Bool
, configActivityNotifyCommand :: Maybe T.Text
, configActivityBell :: Bool
, configShowMessageTimestamps :: Bool
, configShowBackground :: BackgroundInfo
, configShowMessagePreview :: Bool
, configShowChannelList :: Bool
, configShowExpandedChannelTopics :: Bool
, configEnableAspell :: Bool
, configAspellDictionary :: Maybe Text
, configUnsafeUseHTTP :: Bool
, configValidateServerCertificate :: Bool
, configChannelListWidth :: Int
, configLogMaxBufferSize :: Int
, configShowOlderEdits :: Bool
, configShowTypingIndicator :: Bool
, configAbsPath :: Maybe FilePath
, configUserKeys :: KeyConfig
, configHyperlinkingMode :: Bool
, configSyntaxDirs :: [FilePath]
, configDirectChannelExpirationDays :: Int
, configCpuUsagePolicy :: CPUUsagePolicy
, configDefaultAttachmentPath :: Maybe FilePath
, configChannelListOrientation :: ChannelListOrientation
} deriving (Eq, Show)
data CPUUsagePolicy =
SingleCPU
| MultipleCPUs
deriving (Eq, Show)
data BackgroundInfo =
Disabled
| Active
| ActiveCount
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 $ _cdMentionCount info > 0 ||
(not (isMuted chan) &&
(((_cdUpdated info) > lastViewTime) ||
(isJust $ _cdEditedMessageThreshold info)))
mkChannelZipperList :: UTCTime
-> Config
-> Maybe ClientConfig
-> UserPreferences
-> ClientChannels
-> Users
-> [(ChannelListGroup, [ChannelListEntry])]
mkChannelZipperList now config cconfig prefs cs us =
[ let (unread, entries) = getChannelEntriesInOrder cs Ordinary
in (ChannelGroupPublicChannels unread, entries)
, let (unread, entries) = getChannelEntriesInOrder cs Private
in (ChannelGroupPrivateChannels unread, entries)
, let (unread, entries) = getDMChannelEntriesInOrder now config cconfig prefs us cs
in (ChannelGroupDirectMessages unread, entries)
]
getChannelEntriesInOrder :: ClientChannels -> Type -> (Int, [ChannelListEntry])
getChannelEntriesInOrder cs ty =
let matches (_, info) = info^.ccInfo.cdType == ty
pairs = filteredChannels matches cs
unread = length $ filter (== True) $ (hasUnread' . snd) <$> pairs
entries = fmap (CLChannel . fst) $
sortBy (comparing ((^.ccInfo.cdDisplayName.to T.toLower) . snd)) pairs
in (unread, entries)
getDMChannelEntriesInOrder :: UTCTime
-> Config
-> Maybe ClientConfig
-> UserPreferences
-> Users
-> ClientChannels
-> (Int, [ChannelListEntry])
getDMChannelEntriesInOrder now config cconfig prefs us cs =
let oneOnOneDmChans = getDMChannelEntries now config cconfig prefs us cs
groupChans = getGroupDMChannelEntries 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
fst3 (a, _, _) = a
unread = length $ filter id $ fst3 <$> sorted
in (unread, 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
getGroupDMChannelEntries :: UTCTime
-> Config
-> UserPreferences
-> ClientChannels
-> [(Bool, T.Text, ChannelListEntry)]
getGroupDMChannelEntries now config prefs cs =
let matches (_, info) = info^.ccInfo.cdType == Group &&
groupChannelShouldAppear now config prefs info
in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdDisplayName, CLGroupDM cId)) $
filteredChannels matches cs
getDMChannelEntries :: UTCTime
-> Config
-> Maybe ClientConfig
-> UserPreferences
-> Users
-> ClientChannels
-> [(Bool, T.Text, ChannelListEntry)]
getDMChannelEntries 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
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 [
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 [
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)
data Name =
ChannelMessages ChannelId
| MessageInput
| ChannelList
| HelpViewport
| HelpText
| ScriptHelpText
| ThemeHelpText
| SyntaxHighlightHelpText
| KeybindingHelpText
| ChannelSelectString
| CompletionAlternatives
| CompletionList
| JoinChannelList
| UrlList
| MessagePreviewViewport
| ThemeListSearchInput
| UserListSearchInput
| JoinChannelListSearchInput
| UserListSearchResults
| ThemeListSearchResults
| ViewMessageArea
| ViewMessageReactionsArea
| ChannelSidebar
| ChannelSelectInput
| AttachmentList
| AttachmentFileBrowser
| MessageReactionsArea
| ReactionEmojiList
| ReactionEmojiListInput
| TabbedWindowTabBar
| MuteToggleField
| ChannelMentionsField
| DesktopNotificationsField (WithDefault NotifyOption)
| PushNotificationsField (WithDefault NotifyOption)
| ChannelTopicEditor
| ChannelTopicSaveButton
| ChannelTopicCancelButton
| ChannelTopicEditorPreview
deriving (Eq, Show, Ord)
data AuthenticationException =
ConnectError HostCannotConnect
| ResolveError HostNotResolved
| AuthIOError IOError
| LoginError LoginFailureException
| OtherAuthError SomeException
deriving (Show)
data ConnectionInfo =
ConnectionInfo { _ciHostname :: Text
, _ciPort :: Int
, _ciUrlPath :: Text
, _ciUsername :: Text
, _ciPassword :: Text
, _ciAccessToken :: Text
, _ciType :: ConnectionType
}
data PostRef
= MMId PostId
| CLId Int
deriving (Eq, Show)
data ChannelSelectMatch =
ChannelSelectMatch { nameBefore :: Text
, nameMatched :: Text
, nameAfter :: Text
, matchFull :: Text
, matchEntry :: ChannelListEntry
}
deriving (Eq, Show)
data ChannelSelectPattern = CSP MatchType Text
| CSPAny
deriving (Eq, Show)
data MatchType =
Prefix
| Suffix
| Infix
| Equal
| PrefixDMOnly
| PrefixNonDMOnly
deriving (Eq, Show)
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
, _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
data LogCategory =
LogGeneral
| LogAPI
| LogWebsocket
| LogError
| LogUserMark
deriving (Eq, Show)
data LogMessage =
LogMessage { logMessageText :: !Text
, logMessageContext :: !(Maybe LogContext)
, logMessageCategory :: !LogCategory
, logMessageTimestamp :: !UTCTime
}
deriving (Eq, Show)
data LogCommand =
LogToFile FilePath
| LogAMessage !LogMessage
| StopLogging
| ShutdownLogging
| GetLogDestination
| LogSnapshot FilePath
deriving (Show)
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
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
}
data SpecialMention =
MentionAll
| MentionChannel
data AutocompleteAlternative =
UserCompletion User Bool
| SpecialMention SpecialMention
| ChannelCompletion Bool Channel
| SyntaxCompletion Text
| CommandCompletion CompletionSource Text Text Text
| EmojiCompletion Text
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) =
userSigil <> specialMentionName m
autocompleteAlternativeReplacement (UserCompletion u _) =
userSigil <> userUsername u
autocompleteAlternativeReplacement (ChannelCompletion _ c) =
normalChannelSigil <> (sanitizeUserText $ channelName c)
autocompleteAlternativeReplacement (SyntaxCompletion t) =
"```" <> t
autocompleteAlternativeReplacement (CommandCompletion _ t _ _) =
"/" <> t
data AutocompletionType =
ACUsers
| ACChannels
| ACCodeBlockLanguage
| ACEmoji
| ACCommands
deriving (Eq, Show)
data AutocompleteState =
AutocompleteState { _acPreviousSearchString :: Text
, _acCompletionList :: List Name AutocompleteAlternative
, _acType :: AutocompletionType
, _acCachedResponses :: HM.HashMap Text [AutocompleteAlternative]
}
data ChatEditState =
ChatEditState { _cedEditor :: Editor Text Name
, _cedEditMode :: EditMode
, _cedEphemeral :: EphemeralEditState
, _cedInputHistory :: InputHistory
, _cedYankBuffer :: Text
, _cedSpellChecker :: Maybe (Aspell, IO ())
, _cedMisspellings :: Set Text
, _cedAutocomplete :: Maybe AutocompleteState
, _cedAutocompletePending :: Maybe Text
, _cedAttachmentList :: List Name AttachmentData
, _cedFileBrowser :: Maybe (FB.FileBrowser Name)
, _cedJustCompleted :: Bool
}
data AttachmentData =
AttachmentData { attachmentDataFileInfo :: FB.FileInfo
, attachmentDataBytes :: BS.ByteString
}
deriving (Eq, Show)
emptyEditState :: InputHistory -> Maybe (Aspell, IO ()) -> IO ChatEditState
emptyEditState hist sp =
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 = Nothing
, _cedJustCompleted = False
}
type RequestChan = STM.TChan (IO (Maybe (MH ())))
data HelpScreen =
MainHelp
| ScriptHelp
| ThemeHelp
| SyntaxHighlightHelp
| KeybindingHelp
deriving (Eq)
data HelpTopic =
HelpTopic { helpTopicName :: Text
, helpTopicDescription :: Text
, helpTopicScreen :: HelpScreen
, helpTopicViewportName :: Name
}
deriving (Eq)
data PostListContents =
PostListFlagged
| PostListPinned ChannelId
| PostListSearch Text Bool
deriving (Eq)
data Mode =
Main
| ShowHelp HelpTopic Mode
| ChannelSelect
| UrlSelect
| LeaveChannelConfirm
| DeleteChannelConfirm
| MessageSelect
| MessageSelectDeleteConfirm
| PostListOverlay PostListContents
| UserListOverlay
| ReactionEmojiListOverlay
| ChannelListOverlay
| ThemeListOverlay
| ViewMessage
| ManageAttachments
| ManageAttachmentsBrowseFiles
| EditNotifyPrefs
| ChannelTopicWindow
deriving (Eq)
data ConnectionStatus = Connected | Disconnected deriving (Eq)
data TabbedWindowEntry a =
TabbedWindowEntry { tweValue :: a
, tweRender :: a -> ChatState -> Widget Name
, tweHandleEvent :: a -> Vty.Event -> MH ()
, tweTitle :: a -> Bool -> T.Text
, tweShowHandler :: a -> MH ()
}
data TabbedWindowTemplate a =
TabbedWindowTemplate { twtEntries :: [TabbedWindowEntry a]
, twtTitle :: a -> Widget Name
}
data TabbedWindow a =
TabbedWindow { twValue :: a
, twReturnMode :: Mode
, twTemplate :: TabbedWindowTemplate a
, twWindowWidth :: Int
, twWindowHeight :: Int
}
tabbedWindow :: (Show a, Eq a)
=> a
-> TabbedWindowTemplate a
-> Mode
-> (Int, Int)
-> 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
}
getCurrentTabbedWindowEntry :: (Show a, Eq a)
=> TabbedWindow a
-> TabbedWindowEntry a
getCurrentTabbedWindowEntry w =
lookupTabbedWindowEntry (twValue w) w
runTabShowHandlerFor :: (Eq a, Show a) => a -> TabbedWindow a -> MH ()
runTabShowHandlerFor handle w = do
let entry = lookupTabbedWindowEntry handle w
tweShowHandler entry handle
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"
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
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
| ChannelListRight
deriving (Eq, Show)
data ChatState =
ChatState { _csResources :: ChatResources
, _csFocus :: Z.Zipper ChannelListGroup ChannelListEntry
, _csChannelListOrientation :: ChannelListOrientation
, _csMe :: User
, _csMyTeam :: Team
, _csChannels :: ClientChannels
, _csPostMap :: HashMap PostId Message
, _csUsers :: Users
, _timeZone :: TimeZoneSeries
, _csEditState :: ChatEditState
, _csMode :: Mode
, _csShowMessagePreview :: Bool
, _csShowChannelList :: Bool
, _csShowExpandedChannelTopics :: Bool
, _csChannelSelectState :: ChannelSelectState
, _csRecentChannel :: Maybe ChannelId
, _csReturnChannel :: Maybe ChannelId
, _csUrlList :: List Name LinkChoice
, _csConnectionStatus :: ConnectionStatus
, _csWorkerIsBusy :: Maybe (Maybe Int)
, _csMessageSelect :: MessageSelectState
, _csThemeListOverlay :: ListOverlayState InternalTheme ()
, _csPostListOverlay :: PostListOverlayState
, _csUserListOverlay :: ListOverlayState UserInfo UserSearchScope
, _csChannelListOverlay :: ListOverlayState Channel ChannelSearchScope
, _csReactionEmojiListOverlay :: ListOverlayState (Bool, T.Text) ()
, _csClientConfig :: Maybe ClientConfig
, _csPendingChannelChange :: Maybe PendingChannelChange
, _csViewedMessage :: Maybe (Message, TabbedWindow ViewMessageWindowTab)
, _csNotifyPrefs :: Maybe (Form ChannelNotifyProps MHEvent Name)
, _csChannelTopicDialog :: ChannelTopicDialogState
}
data ViewMessageWindowTab =
VMTabMessage
| VMTabReactions
deriving (Eq, Show)
data PendingChannelChange =
ChangeByChannelId ChannelId (Maybe (MH ()))
| ChangeByUserId UserId
data StartupStateInfo =
StartupStateInfo { startupStateResources :: ChatResources
, startupStateChannelZipper :: Z.Zipper ChannelListGroup ChannelListEntry
, startupStateConnectedUser :: User
, startupStateTeam :: Team
, startupStateTimeZone :: TimeZoneSeries
, startupStateInitialHistory :: InputHistory
, startupStateSpellChecker :: Maybe (Aspell, IO ())
}
data ChannelTopicDialogState =
ChannelTopicDialogState { _channelTopicDialogEditor :: Editor T.Text Name
, _channelTopicDialogFocus :: FocusRing Name
}
newState :: StartupStateInfo -> IO ChatState
newState (StartupStateInfo {..}) = do
editState <- emptyEditState startupStateInitialHistory startupStateSpellChecker
let config = _crConfiguration startupStateResources
return ChatState { _csResources = startupStateResources
, _csFocus = startupStateChannelZipper
, _csChannelListOrientation = configChannelListOrientation config
, _csMe = startupStateConnectedUser
, _csMyTeam = startupStateTeam
, _csChannels = noChannels
, _csPostMap = HM.empty
, _csUsers = noUsers
, _timeZone = startupStateTimeZone
, _csEditState = editState
, _csMode = Main
, _csShowMessagePreview = configShowMessagePreview config
, _csShowChannelList = configShowChannelList config
, _csShowExpandedChannelTopics = configShowExpandedChannelTopics config
, _csChannelSelectState = emptyChannelSelectState
, _csRecentChannel = Nothing
, _csReturnChannel = Nothing
, _csUrlList = list UrlList mempty 2
, _csConnectionStatus = Connected
, _csWorkerIsBusy = Nothing
, _csMessageSelect = MessageSelectState Nothing
, _csThemeListOverlay = nullThemeListOverlayState
, _csPostListOverlay = PostListOverlayState emptyDirSeq Nothing
, _csUserListOverlay = nullUserListOverlayState
, _csChannelListOverlay = nullChannelListOverlayState
, _csReactionEmojiListOverlay = nullEmojiListOverlayState
, _csClientConfig = Nothing
, _csPendingChannelChange = Nothing
, _csViewedMessage = Nothing
, _csNotifyPrefs = Nothing
, _csChannelTopicDialog = newChannelTopicDialog ""
}
newChannelTopicDialog :: T.Text -> ChannelTopicDialogState
newChannelTopicDialog t =
ChannelTopicDialogState { _channelTopicDialogEditor = editor ChannelTopicEditor Nothing t
, _channelTopicDialogFocus = focusRing [ ChannelTopicEditor
, ChannelTopicSaveButton
, ChannelTopicCancelButton
]
}
nullChannelListOverlayState :: ListOverlayState Channel ChannelSearchScope
nullChannelListOverlayState =
let newList rs = list JoinChannelList rs 2
in ListOverlayState { _listOverlaySearchResults = newList mempty
, _listOverlaySearchInput = editor JoinChannelListSearchInput (Just 1) ""
, _listOverlaySearchScope = AllChannels
, _listOverlaySearching = False
, _listOverlayEnterHandler = const $ return False
, _listOverlayNewList = newList
, _listOverlayFetchResults = const $ const $ const $ return mempty
, _listOverlayRecordCount = Nothing
, _listOverlayReturnMode = Main
}
nullThemeListOverlayState :: ListOverlayState InternalTheme ()
nullThemeListOverlayState =
let newList rs = list ThemeListSearchResults rs 3
in ListOverlayState { _listOverlaySearchResults = newList mempty
, _listOverlaySearchInput = editor ThemeListSearchInput (Just 1) ""
, _listOverlaySearchScope = ()
, _listOverlaySearching = False
, _listOverlayEnterHandler = const $ return False
, _listOverlayNewList = newList
, _listOverlayFetchResults = const $ const $ const $ return mempty
, _listOverlayRecordCount = Nothing
, _listOverlayReturnMode = Main
}
nullUserListOverlayState :: ListOverlayState UserInfo UserSearchScope
nullUserListOverlayState =
let newList rs = list UserListSearchResults rs 1
in ListOverlayState { _listOverlaySearchResults = newList mempty
, _listOverlaySearchInput = editor UserListSearchInput (Just 1) ""
, _listOverlaySearchScope = AllUsers Nothing
, _listOverlaySearching = False
, _listOverlayEnterHandler = const $ return False
, _listOverlayNewList = newList
, _listOverlayFetchResults = const $ const $ const $ return mempty
, _listOverlayRecordCount = Nothing
, _listOverlayReturnMode = Main
}
nullEmojiListOverlayState :: ListOverlayState (Bool, T.Text) ()
nullEmojiListOverlayState =
let newList rs = list ReactionEmojiList rs 1
in ListOverlayState { _listOverlaySearchResults = newList mempty
, _listOverlaySearchInput = editor ReactionEmojiListInput (Just 1) ""
, _listOverlaySearchScope = ()
, _listOverlaySearching = False
, _listOverlayEnterHandler = const $ return False
, _listOverlayNewList = newList
, _listOverlayFetchResults = const $ const $ const $ return mempty
, _listOverlayRecordCount = Nothing
, _listOverlayReturnMode = MessageSelect
}
getServerBaseUrl :: MH TeamBaseURL
getServerBaseUrl = do
st <- use id
return $ serverBaseUrl st
serverBaseUrl :: ChatState -> TeamBaseURL
serverBaseUrl st =
let baseUrl = connectionDataURL $ _crConn $ _csResources st
tName = teamName $ _csMyTeam st
in TeamBaseURL (TeamURLName $ sanitizeUserText tName) baseUrl
data ChannelSelectState =
ChannelSelectState { _channelSelectInput :: Editor Text Name
, _channelSelectMatches :: Z.Zipper ChannelListGroup ChannelSelectMatch
}
emptyChannelSelectState :: ChannelSelectState
emptyChannelSelectState =
ChannelSelectState { _channelSelectInput = editor ChannelSelectInput (Just 1) ""
, _channelSelectMatches = Z.fromList []
}
data MessageSelectState =
MessageSelectState { selectMessageId :: Maybe MessageId
}
data PostListOverlayState =
PostListOverlayState { _postListPosts :: Messages
, _postListSelected :: Maybe PostId
}
data InternalTheme =
InternalTheme { internalThemeName :: Text
, internalTheme :: Theme
, internalThemeDesc :: Text
}
data ListOverlayState a b =
ListOverlayState { _listOverlaySearchResults :: List Name a
, _listOverlaySearchInput :: Editor Text Name
, _listOverlaySearchScope :: b
, _listOverlaySearching :: Bool
, _listOverlayEnterHandler :: a -> MH Bool
, _listOverlayNewList :: Vec.Vector a -> List Name a
, _listOverlayFetchResults :: b -> Session -> Text -> IO (Vec.Vector a)
, _listOverlayRecordCount :: Maybe Int
, _listOverlayReturnMode :: Mode
}
data UserSearchScope =
ChannelMembers ChannelId TeamId
| ChannelNonMembers ChannelId TeamId
| AllUsers (Maybe TeamId)
data ChannelSearchScope =
AllChannels
data WebsocketAction =
UserTyping UTCTime ChannelId (Maybe PostId)
deriving (Read, Show, Eq, Ord)
data LogContext =
LogContext { logContextChannelId :: Maybe ChannelId
}
deriving (Eq, Show)
data UserFetch =
UserFetchById UserId
| UserFetchByUsername Text
| UserFetchByNickname Text
deriving (Eq, Show)
data MHState =
MHState { mhCurrentState :: ChatState
, mhNextAction :: ChatState -> EventM Name (Next ChatState)
, mhUsersToFetch :: [UserFetch]
, mhPendingStatusList :: Maybe [UserId]
}
newtype MH a =
MH { fromMH :: R.ReaderT (Maybe LogContext) (St.StateT MHState (EventM Name)) a }
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
getLogContext :: MH (Maybe LogContext)
getLogContext = MH R.ask
mhLog :: LogCategory -> Text -> MH ()
mhLog cat msg = do
logger <- mhGetIOLogger
liftIO $ logger cat msg
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
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
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 })
mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH ()
mhSuspendAndResume mote = MH $ do
s <- St.get
St.put $ s { mhNextAction = \ _ -> Brick.suspendAndResume (mote $ mhCurrentState s) }
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 x = MH (return x)
MH x >>= f = MH (x >>= \ x' -> fromMH (f x'))
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
data MHEvent =
WSEvent WebsocketEvent
| WSActionResponse WebsocketActionResponse
| RespEvent (MH ())
| RefreshWebsocketEvent
| WebsocketParseError String
| WebsocketDisconnect
| WebsocketConnect
| BGIdle
| BGBusy (Maybe Int)
| RateLimitExceeded Int
| RateLimitSettingsMissing
| RequestDropped
| IEvent InternalEvent
data InternalEvent =
DisplayError MHError
| LoggingStarted FilePath
| LoggingStopped FilePath
| LogStartFailed FilePath String
| LogDestination (Maybe FilePath)
| LogSnapshotSucceeded FilePath
| LogSnapshotFailed FilePath String
data MHError =
GenericError T.Text
| NoSuchChannel T.Text
| NoSuchUser T.Text
| AmbiguousName T.Text
| ServerError MattermostError
| ClipboardError T.Text
| ConfigOptionMissing T.Text
| ProgramExecutionFailed T.Text T.Text
| NoSuchScript T.Text
| NoSuchHelpTopic T.Text
| AsyncErrEvent SomeException
deriving (Show)
makeLenses ''ChatResources
makeLenses ''ChatState
makeLenses ''ChatEditState
makeLenses ''AutocompleteState
makeLenses ''PostListOverlayState
makeLenses ''ListOverlayState
makeLenses ''ChannelSelectState
makeLenses ''UserPreferences
makeLenses ''ConnectionInfo
makeLenses ''ChannelTopicDialogState
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
csCurrentChannelId :: SimpleGetter ChatState ChannelId
csCurrentChannelId = csFocus.to Z.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 :: Z.Zipper ChannelListGroup ChannelListEntry -> [UserId]
userIdsFromZipper z =
concat $ (catMaybes . fmap channelListEntryUserId . snd) <$> Z.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
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!"
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
Nothing -> return msg
Just m -> return m
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)
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
mh invalidateCache
data SidebarUpdate =
SidebarUpdateImmediate
| SidebarUpdateDeferred
deriving (Eq, Show)
resetAutocomplete :: MH ()
resetAutocomplete = do
csEditState.cedAutocomplete .= Nothing
csEditState.cedAutocompletePending .= Nothing
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)
type CmdExec a = a -> MH ()
data Cmd =
forall a. Cmd { cmdName :: Text
, cmdDescr :: Text
, cmdArgSpec :: CmdArgs a
, cmdAction :: CmdExec a
}
commandName :: Cmd -> Text
commandName (Cmd name _ _ _ ) = name
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
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
myUsername :: ChatState -> Text
myUsername st = userUsername $ st^.csMe
userByUsername :: Text -> ChatState -> Maybe UserInfo
userByUsername name st = do
snd <$> (findUserByUsername name $ st^.csUsers)
userByNickname :: Text -> ChatState -> Maybe UserInfo
userByNickname name st =
snd <$> (findUserByNickname name $ st^.csUsers)
getUsers :: MH Users
getUsers = use csUsers
type UserSet = Set Text
type ChannelSet = Set Text
data HighlightSet =
HighlightSet { hUserSet :: Set Text
, hChannelSet :: Set Text
, hSyntaxMap :: SyntaxMap
}
getHighlightSet :: ChatState -> HighlightSet
getHighlightSet st =
HighlightSet { hUserSet = addSpecialUserMentions $ getUsernameSet $ st^.csUsers
, hChannelSet = getChannelNameSet $ st^.csChannels
, hSyntaxMap = st^.csResources.crSyntaxMap
}
attrNameToConfig :: Brick.AttrName -> Text
attrNameToConfig = T.pack . intercalate "." . Brick.attrNameComponents
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)