1{-# LANGUAGE GADTs #-} 2{-# LANGUAGE KindSignatures #-} 3{-# LANGUAGE TemplateHaskell #-} 4{-# LANGUAGE MultiWayIf #-} 5{-# LANGUAGE RankNTypes #-} 6{-# LANGUAGE MultiParamTypeClasses #-} 7{-# LANGUAGE RecordWildCards #-} 8{-# LANGUAGE TupleSections #-} 9{-# LANGUAGE FlexibleInstances #-} 10module Matterhorn.Types 11 ( ConnectionStatus(..) 12 , HelpTopic(..) 13 , MessageSelectState(..) 14 , ProgramOutput(..) 15 , MHEvent(..) 16 , InternalEvent(..) 17 , Name(..) 18 , ChannelSelectMatch(..) 19 , StartupStateInfo(..) 20 , MHError(..) 21 , AttachmentData(..) 22 , CPUUsagePolicy(..) 23 , SemEq(..) 24 , tabbedWindow 25 , getCurrentTabbedWindowEntry 26 , tabbedWindowNextTab 27 , tabbedWindowPreviousTab 28 , runTabShowHandlerFor 29 , getServerBaseUrl 30 , serverBaseUrl 31 , TabbedWindow(..) 32 , TabbedWindowEntry(..) 33 , TabbedWindowTemplate(..) 34 , ConnectionInfo(..) 35 , SidebarUpdate(..) 36 , PendingChannelChange(..) 37 , ViewMessageWindowTab(..) 38 , clearChannelUnreadStatus 39 , ChannelListEntry(..) 40 , ChannelListEntryType(..) 41 , ChannelListOrientation(..) 42 , channelListEntryUserId 43 , userIdsFromZipper 44 , entryIsDMEntry 45 , ciHostname 46 , ciPort 47 , ciUrlPath 48 , ciUsername 49 , ciPassword 50 , ciType 51 , ciAccessToken 52 , newChannelTopicDialog 53 , ChannelTopicDialogState(..) 54 , channelTopicDialogEditor 55 , channelTopicDialogFocus 56 57 , newSaveAttachmentDialog 58 , SaveAttachmentDialogState(..) 59 , attachmentPathEditor 60 , attachmentPathDialogFocus 61 62 , Config(..) 63 , configUserL 64 , configHostL 65 , configTeamL 66 , configPortL 67 , configUrlPathL 68 , configPassL 69 , configTokenL 70 , configTimeFormatL 71 , configDateFormatL 72 , configThemeL 73 , configThemeCustomizationFileL 74 , configSmartBacktickL 75 , configSmartEditingL 76 , configURLOpenCommandL 77 , configURLOpenCommandInteractiveL 78 , configActivityNotifyCommandL 79 , configActivityNotifyVersionL 80 , configActivityBellL 81 , configShowMessageTimestampsL 82 , configShowBackgroundL 83 , configShowMessagePreviewL 84 , configShowChannelListL 85 , configShowExpandedChannelTopicsL 86 , configEnableAspellL 87 , configAspellDictionaryL 88 , configUnsafeUseHTTPL 89 , configValidateServerCertificateL 90 , configChannelListWidthL 91 , configLogMaxBufferSizeL 92 , configShowOlderEditsL 93 , configShowTypingIndicatorL 94 , configAbsPathL 95 , configUserKeysL 96 , configHyperlinkingModeL 97 , configSyntaxDirsL 98 , configDirectChannelExpirationDaysL 99 , configCpuUsagePolicyL 100 , configDefaultAttachmentPathL 101 , configChannelListOrientationL 102 , configMouseModeL 103 104 , NotificationVersion(..) 105 , HelpScreen(..) 106 , PasswordSource(..) 107 , TokenSource(..) 108 , MatchType(..) 109 , Mode(..) 110 , ChannelSelectPattern(..) 111 , PostListContents(..) 112 , AuthenticationException(..) 113 , BackgroundInfo(..) 114 , RequestChan 115 , UserFetch(..) 116 , writeBChan 117 , InternalTheme(..) 118 119 , attrNameToConfig 120 121 , sortTeams 122 , mkTeamZipper 123 , mkTeamZipperFromIds 124 , teamZipperIds 125 , mkChannelZipperList 126 , ChannelListGroup(..) 127 , channelListGroupUnread 128 , nonDMChannelListGroupUnread 129 130 , trimChannelSigil 131 132 , ChannelSelectState(..) 133 , channelSelectMatches 134 , channelSelectInput 135 , emptyChannelSelectState 136 137 , TeamState(..) 138 , tsFocus 139 , tsMode 140 , tsPendingChannelChange 141 , tsRecentChannel 142 , tsReturnChannel 143 , tsEditState 144 , tsMessageSelect 145 , tsTeam 146 , tsChannelSelectState 147 , tsUrlList 148 , tsViewedMessage 149 , tsPostListOverlay 150 , tsUserListOverlay 151 , tsChannelListOverlay 152 , tsNotifyPrefs 153 , tsChannelTopicDialog 154 , tsReactionEmojiListOverlay 155 , tsThemeListOverlay 156 , tsSaveAttachmentDialog 157 158 , ChatState 159 , newState 160 , newTeamState 161 162 , csTeamZipper 163 , csCurrentTeam 164 , csTeams 165 , csTeam 166 , csChannelListOrientation 167 , csResources 168 , csLastMouseDownEvent 169 , csCurrentChannel 170 , csCurrentChannelId 171 , csCurrentTeamId 172 , csPostMap 173 , csUsers 174 , csConnectionStatus 175 , csWorkerIsBusy 176 , csChannel 177 , csChannels 178 , csClientConfig 179 , csInputHistory 180 , csMe 181 , timeZone 182 , whenMode 183 , setMode 184 , setMode' 185 186 , ChatEditState 187 , emptyEditState 188 , cedAttachmentList 189 , cedFileBrowser 190 , unsafeCedFileBrowser 191 , cedYankBuffer 192 , cedSpellChecker 193 , cedMisspellings 194 , cedEditMode 195 , cedEphemeral 196 , cedEditor 197 , cedAutocomplete 198 , cedAutocompletePending 199 , cedJustCompleted 200 201 , AutocompleteState(..) 202 , acPreviousSearchString 203 , acCompletionList 204 , acCachedResponses 205 , acType 206 207 , AutocompletionType(..) 208 209 , CompletionSource(..) 210 , AutocompleteAlternative(..) 211 , autocompleteAlternativeReplacement 212 , SpecialMention(..) 213 , specialMentionName 214 , isSpecialMention 215 216 , PostListOverlayState 217 , postListSelected 218 , postListPosts 219 220 , UserSearchScope(..) 221 , ChannelSearchScope(..) 222 223 , ListOverlayState 224 , listOverlaySearchResults 225 , listOverlaySearchInput 226 , listOverlaySearchScope 227 , listOverlaySearching 228 , listOverlayEnterHandler 229 , listOverlayNewList 230 , listOverlayFetchResults 231 , listOverlayRecordCount 232 , listOverlayReturnMode 233 234 , getUsers 235 236 , ChatResources(..) 237 , crUserPreferences 238 , crEventQueue 239 , crTheme 240 , crStatusUpdateChan 241 , crSubprocessLog 242 , crWebsocketActionChan 243 , crWebsocketThreadId 244 , crRequestQueue 245 , crFlaggedPosts 246 , crConn 247 , crConfiguration 248 , crSyntaxMap 249 , crLogManager 250 , crEmoji 251 , getSession 252 , getResourceSession 253 254 , specialUserMentions 255 256 , applyTeamOrder 257 , refreshTeamZipper 258 259 , UserPreferences(UserPreferences) 260 , userPrefShowJoinLeave 261 , userPrefFlaggedPostList 262 , userPrefGroupChannelPrefs 263 , userPrefDirectChannelPrefs 264 , userPrefTeammateNameDisplayMode 265 , userPrefTeamOrder 266 , userPrefFavoriteChannelPrefs 267 , dmChannelShowPreference 268 , groupChannelShowPreference 269 , favoriteChannelPreference 270 271 , defaultUserPreferences 272 , setUserPreferences 273 274 , WebsocketAction(..) 275 276 , Cmd(..) 277 , commandName 278 , CmdArgs(..) 279 280 , MH 281 , runMHEvent 282 , scheduleUserFetches 283 , scheduleUserStatusFetches 284 , getScheduledUserFetches 285 , getScheduledUserStatusFetches 286 , mh 287 , generateUUID 288 , generateUUID_IO 289 , mhSuspendAndResume 290 , mhHandleEventLensed 291 , mhHandleEventLensed' 292 , St.gets 293 , mhError 294 295 , mhLog 296 , mhGetIOLogger 297 , ioLogWithManager 298 , LogContext(..) 299 , withLogContext 300 , withLogContextChannelId 301 , getLogContext 302 , LogMessage(..) 303 , LogCommand(..) 304 , LogCategory(..) 305 306 , LogManager(..) 307 , startLoggingToFile 308 , stopLoggingToFile 309 , requestLogSnapshot 310 , requestLogDestination 311 , sendLogMessage 312 313 , requestQuit 314 , getMessageForPostId 315 , getParentMessage 316 , getReplyRootMessage 317 , resetSpellCheckTimer 318 , withChannel 319 , withChannelOrDefault 320 , userList 321 , resetAutocomplete 322 , isMine 323 , setUserStatus 324 , myUser 325 , myUsername 326 , myUserId 327 , usernameForUserId 328 , userByUsername 329 , userByNickname 330 , channelIdByChannelName 331 , channelIdByUsername 332 , userById 333 , allUserIds 334 , addNewUser 335 , useNickname 336 , useNickname' 337 , displayNameForUserId 338 , displayNameForUser 339 , raiseInternalEvent 340 , getNewMessageCutoff 341 , getEditedMessageCutoff 342 343 , HighlightSet(..) 344 , UserSet 345 , ChannelSet 346 , getHighlightSet 347 , emptyHSet 348 349 , moveLeft 350 , moveRight 351 352 , module Matterhorn.Types.Channels 353 , module Matterhorn.Types.Messages 354 , module Matterhorn.Types.Posts 355 , module Matterhorn.Types.Users 356 ) 357where 358 359import Prelude () 360import Matterhorn.Prelude 361 362import qualified Graphics.Vty as Vty 363import qualified Brick 364import Brick ( EventM, Next, Widget ) 365import Brick.Focus ( FocusRing, focusRing ) 366import Brick.Themes ( Theme ) 367import Brick.Main ( invalidateCache, invalidateCacheEntry ) 368import Brick.AttrMap ( AttrMap ) 369import qualified Brick.BChan as BCH 370import Brick.Forms (Form) 371import Brick.Widgets.Edit ( Editor, editor, applyEdit ) 372import Brick.Widgets.List ( List, list ) 373import qualified Brick.Widgets.FileBrowser as FB 374import Control.Concurrent ( ThreadId ) 375import Control.Concurrent.Async ( Async ) 376import qualified Control.Concurrent.STM as STM 377import Control.Exception ( SomeException ) 378import qualified Control.Monad.Fail as MHF 379import qualified Control.Monad.State as St 380import qualified Control.Monad.Reader as R 381import qualified Data.Set as Set 382import qualified Data.ByteString as BS 383import qualified Data.Foldable as F 384import Data.Function ( on ) 385import qualified Data.Kind as K 386import Data.Ord ( comparing ) 387import qualified Data.HashMap.Strict as HM 388import Data.List ( sortBy, nub, elemIndex, partition ) 389import qualified Data.Sequence as Seq 390import qualified Data.Text as T 391import qualified Data.Text.Zipper as Z2 392import Data.Time.Clock ( getCurrentTime, addUTCTime ) 393import Data.UUID ( UUID ) 394import qualified Data.Vector as Vec 395import Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=) 396 , (%=), (^?), (.~) 397 , _Just, Traversal', preuse, to 398 , SimpleGetter 399 ) 400import Network.Connection ( HostNotResolved, HostCannotConnect ) 401import Skylighting.Types ( SyntaxMap ) 402import System.Exit ( ExitCode ) 403import System.Random ( randomIO ) 404import Text.Aspell ( Aspell ) 405 406import Network.Mattermost ( ConnectionData ) 407import Network.Mattermost.Exceptions 408import Network.Mattermost.Lenses 409import Network.Mattermost.Types 410import Network.Mattermost.Types.Config 411import Network.Mattermost.WebSocket ( WebsocketEvent, WebsocketActionResponse ) 412 413import Matterhorn.Constants ( userSigil, normalChannelSigil ) 414import Matterhorn.InputHistory 415import Matterhorn.Emoji 416import Matterhorn.Types.Common 417import Matterhorn.Types.Channels 418import Matterhorn.Types.DirectionalSeq ( emptyDirSeq ) 419import Matterhorn.Types.KeyEvents 420import Matterhorn.Types.Messages 421import Matterhorn.Types.Posts 422import Matterhorn.Types.RichText ( TeamBaseURL(..), TeamURLName(..) ) 423import Matterhorn.Types.Users 424import qualified Matterhorn.Zipper as Z 425 426 427-- * Configuration 428 429-- | A notification version for the external notifier 430data NotificationVersion = 431 NotifyV1 432 | NotifyV2 433 deriving (Eq, Read, Show) 434 435-- | A user password is either given to us directly, or a command 436-- which we execute to find the password. 437data PasswordSource = 438 PasswordString Text 439 | PasswordCommand Text 440 deriving (Eq, Read, Show) 441 442-- | An access token source. 443data TokenSource = 444 TokenString Text 445 | TokenCommand Text 446 deriving (Eq, Read, Show) 447 448-- | The type of channel list group headings. Integer arguments indicate 449-- total number of channels in the group that have unread activity. 450data ChannelListGroup = 451 ChannelGroupPublicChannels Int 452 | ChannelGroupPrivateChannels Int 453 | ChannelGroupFavoriteChannels Int 454 | ChannelGroupDirectMessages Int 455 deriving (Eq) 456 457channelListGroupUnread :: ChannelListGroup -> Int 458channelListGroupUnread (ChannelGroupPublicChannels n) = n 459channelListGroupUnread (ChannelGroupPrivateChannels n) = n 460channelListGroupUnread (ChannelGroupFavoriteChannels n) = n 461channelListGroupUnread (ChannelGroupDirectMessages n) = n 462 463 464nonDMChannelListGroupUnread :: ChannelListGroup -> Int 465nonDMChannelListGroupUnread (ChannelGroupPublicChannels n) = n 466nonDMChannelListGroupUnread (ChannelGroupPrivateChannels n) = n 467nonDMChannelListGroupUnread (ChannelGroupFavoriteChannels n) = n 468nonDMChannelListGroupUnread (ChannelGroupDirectMessages _) = 0 469 470-- | The type of channel list entries. 471data ChannelListEntry = 472 ChannelListEntry { channelListEntryChannelId :: ChannelId 473 , channelListEntryType :: ChannelListEntryType 474 , channelListEntryUnread :: Bool 475 , channelListEntrySortValue :: T.Text 476 , channelListEntryFavorite :: Bool 477 } 478 deriving (Eq, Show, Ord) 479 480data ChannelListEntryType = 481 CLChannel 482 -- ^ A non-DM entry 483 | CLUserDM UserId 484 -- ^ A single-user DM entry 485 | CLGroupDM 486 -- ^ A multi-user DM entry 487 deriving (Eq, Show, Ord) 488 489-- | This is how we represent the user's configuration. Most fields 490-- correspond to configuration file settings (see Config.hs) but some 491-- are for internal book-keeping purposes only. 492data Config = 493 Config { configUser :: Maybe Text 494 -- ^ The username to use when connecting. 495 , configHost :: Maybe Text 496 -- ^ The hostname to use when connecting. 497 , configTeam :: Maybe Text 498 -- ^ The team name to use when connecting. 499 , configPort :: Int 500 -- ^ The port to use when connecting. 501 , configUrlPath :: Maybe Text 502 -- ^ The server path to use when connecting. 503 , configPass :: Maybe PasswordSource 504 -- ^ The password source to use when connecting. 505 , configToken :: Maybe TokenSource 506 -- ^ The token source to use when connecting. 507 , configTimeFormat :: Maybe Text 508 -- ^ The format string for timestamps. 509 , configDateFormat :: Maybe Text 510 -- ^ The format string for dates. 511 , configTheme :: Maybe Text 512 -- ^ The name of the theme to use. 513 , configThemeCustomizationFile :: Maybe Text 514 -- ^ The path to the theme customization file, if any. 515 , configSmartBacktick :: Bool 516 -- ^ Whether to enable smart quoting characters. 517 , configSmartEditing :: Bool 518 -- ^ Whether to enable smart editing behaviors. 519 , configURLOpenCommand :: Maybe Text 520 -- ^ The command to use to open URLs. 521 , configURLOpenCommandInteractive :: Bool 522 -- ^ Whether the URL-opening command is interactive (i.e. 523 -- whether it should be given control of the terminal). 524 , configActivityNotifyCommand :: Maybe T.Text 525 -- ^ The command to run for activity notifications. 526 , configActivityNotifyVersion :: NotificationVersion 527 -- ^ The activity notifier version. 528 , configActivityBell :: Bool 529 -- ^ Whether to ring the terminal bell on activity. 530 , configShowMessageTimestamps :: Bool 531 -- ^ Whether to show timestamps on messages. 532 , configShowBackground :: BackgroundInfo 533 -- ^ Whether to show async background worker thread info. 534 , configShowMessagePreview :: Bool 535 -- ^ Whether to show the message preview area. 536 , configShowChannelList :: Bool 537 -- ^ Whether to show the channel list. 538 , configShowExpandedChannelTopics :: Bool 539 -- ^ Whether to show expanded channel topics. 540 , configEnableAspell :: Bool 541 -- ^ Whether to enable Aspell spell checking. 542 , configAspellDictionary :: Maybe Text 543 -- ^ A specific Aspell dictionary name to use. 544 , configUnsafeUseHTTP :: Bool 545 -- ^ Whether to permit an insecure HTTP connection. 546 , configValidateServerCertificate :: Bool 547 -- ^ Whether to validate TLS certificates. 548 , configChannelListWidth :: Int 549 -- ^ The width, in columns, of the channel list sidebar. 550 , configLogMaxBufferSize :: Int 551 -- ^ The maximum size, in log entries, of the internal log 552 -- message buffer. 553 , configShowOlderEdits :: Bool 554 -- ^ Whether to highlight the edit indicator on edits made 555 -- prior to the beginning of the current session. 556 , configShowTypingIndicator :: Bool 557 -- ^ Whether to show the typing indicator for other users, 558 -- and whether to send typing notifications to other users. 559 , configAbsPath :: Maybe FilePath 560 -- ^ A book-keeping field for the absolute path to the 561 -- configuration. (Not a user setting.) 562 , configUserKeys :: KeyConfig 563 -- ^ The user's keybinding configuration. 564 , configHyperlinkingMode :: Bool 565 -- ^ Whether to enable terminal hyperlinking mode. 566 , configSyntaxDirs :: [FilePath] 567 -- ^ The search path for syntax description XML files. 568 , configDirectChannelExpirationDays :: Int 569 -- ^ The number of days to show a user in the channel menu after a direct 570 -- message with them. 571 , configCpuUsagePolicy :: CPUUsagePolicy 572 -- ^ The CPU usage policy for the application. 573 , configDefaultAttachmentPath :: Maybe FilePath 574 -- ^ The default path for browsing attachments 575 , configChannelListOrientation :: ChannelListOrientation 576 -- ^ The orientation of the channel list. 577 , configMouseMode :: Bool 578 -- ^ Whether to enable mouse support in matterhorn 579 } deriving (Eq, Show) 580 581-- | The policy for CPU usage. 582-- 583-- The idea is that Matterhorn can benefit from using multiple CPUs, 584-- but the exact number is application-determined. We expose this policy 585-- setting to the user in the configuration. 586data CPUUsagePolicy = 587 SingleCPU 588 -- ^ Constrain the application to use one CPU. 589 | MultipleCPUs 590 -- ^ Permit the usage of multiple CPUs (the exact number is 591 -- determined by the application). 592 deriving (Eq, Show) 593 594-- | The state of the UI diagnostic indicator for the async worker 595-- thread. 596data BackgroundInfo = 597 Disabled 598 -- ^ Disable (do not show) the indicator. 599 | Active 600 -- ^ Show the indicator when the thread is working. 601 | ActiveCount 602 -- ^ Show the indicator when the thread is working, but include the 603 -- thread's work queue length. 604 deriving (Eq, Show) 605 606data UserPreferences = 607 UserPreferences { _userPrefShowJoinLeave :: Bool 608 , _userPrefFlaggedPostList :: Seq FlaggedPost 609 , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool 610 , _userPrefDirectChannelPrefs :: HashMap UserId Bool 611 , _userPrefFavoriteChannelPrefs :: HashMap ChannelId Bool 612 , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode 613 , _userPrefTeamOrder :: Maybe [TeamId] 614 } 615 616hasUnread' :: ClientChannel -> Bool 617hasUnread' chan = fromMaybe False $ do 618 let info = _ccInfo chan 619 lastViewTime <- _cdViewed info 620 return $ _cdMentionCount info > 0 || 621 (not (isMuted chan) && 622 (((_cdUpdated info) > lastViewTime) || 623 (isJust $ _cdEditedMessageThreshold info))) 624 625mkChannelZipperList :: UTCTime 626 -> Config 627 -> TeamId 628 -> Maybe ClientConfig 629 -> UserPreferences 630 -> ClientChannels 631 -> Users 632 -> [(ChannelListGroup, [ChannelListEntry])] 633mkChannelZipperList now config tId cconfig prefs cs us = 634 let (privFavs, privEntries) = partitionFavorites $ getChannelEntriesByType tId prefs cs Private 635 (normFavs, normEntries) = partitionFavorites $ getChannelEntriesByType tId prefs cs Ordinary 636 (dmFavs, dmEntries) = partitionFavorites $ getDMChannelEntries now config cconfig prefs us cs 637 favEntries = privFavs <> normFavs <> dmFavs 638 in [ let unread = length $ filter channelListEntryUnread favEntries 639 in (ChannelGroupFavoriteChannels unread, sortChannelListEntries favEntries) 640 , let unread = length $ filter channelListEntryUnread normEntries 641 in (ChannelGroupPublicChannels unread, sortChannelListEntries normEntries) 642 , let unread = length $ filter channelListEntryUnread privEntries 643 in (ChannelGroupPrivateChannels unread, sortChannelListEntries privEntries) 644 , let unread = length $ filter channelListEntryUnread dmEntries 645 in (ChannelGroupDirectMessages unread, sortDMChannelListEntries dmEntries) 646 ] 647 648sortChannelListEntries :: [ChannelListEntry] -> [ChannelListEntry] 649sortChannelListEntries = sortBy (comparing channelListEntrySortValue) 650 651sortDMChannelListEntries :: [ChannelListEntry] -> [ChannelListEntry] 652sortDMChannelListEntries = sortBy compareDMChannelListEntries 653 654partitionFavorites :: [ChannelListEntry] -> ([ChannelListEntry], [ChannelListEntry]) 655partitionFavorites = partition channelListEntryFavorite 656 657getChannelEntriesByType :: TeamId -> UserPreferences -> ClientChannels -> Type -> [ChannelListEntry] 658getChannelEntriesByType tId prefs cs ty = 659 let matches (_, info) = info^.ccInfo.cdType == ty && 660 info^.ccInfo.cdTeamId == Just tId 661 pairs = filteredChannels matches cs 662 entries = mkEntry <$> pairs 663 mkEntry (cId, ch) = ChannelListEntry { channelListEntryChannelId = cId 664 , channelListEntryType = CLChannel 665 , channelListEntryUnread = hasUnread' ch 666 , channelListEntrySortValue = ch^.ccInfo.cdDisplayName.to T.toLower 667 , channelListEntryFavorite = isFavorite prefs cId 668 } 669 in entries 670 671getDMChannelEntries :: UTCTime 672 -> Config 673 -> Maybe ClientConfig 674 -> UserPreferences 675 -> Users 676 -> ClientChannels 677 -> [ChannelListEntry] 678getDMChannelEntries now config cconfig prefs us cs = 679 let oneOnOneDmChans = getSingleDMChannelEntries now config cconfig prefs us cs 680 groupChans = getGroupDMChannelEntries now config prefs cs 681 in groupChans <> oneOnOneDmChans 682 683compareDMChannelListEntries :: ChannelListEntry -> ChannelListEntry -> Ordering 684compareDMChannelListEntries e1 e2 = 685 let u1 = channelListEntryUnread e1 686 u2 = channelListEntryUnread e2 687 n1 = channelListEntrySortValue e1 688 n2 = channelListEntrySortValue e2 689 in if u1 == u2 690 then compare n1 n2 691 else if u1 && not u2 692 then LT 693 else GT 694 695useNickname' :: Maybe ClientConfig -> UserPreferences -> Bool 696useNickname' clientConfig prefs = 697 let serverSetting = case clientConfig^?_Just.to clientConfigTeammateNameDisplay of 698 Just TMNicknameOrFullname -> Just True 699 _ -> Nothing 700 accountSetting = (== TMNicknameOrFullname) <$> (_userPrefTeammateNameDisplayMode prefs) 701 fallback = False 702 in fromMaybe fallback $ accountSetting <|> serverSetting 703 704displayNameForUser :: UserInfo -> Maybe ClientConfig -> UserPreferences -> Text 705displayNameForUser u clientConfig prefs 706 | useNickname' clientConfig prefs = 707 fromMaybe (u^.uiName) (u^.uiNickName) 708 | otherwise = 709 u^.uiName 710 711getGroupDMChannelEntries :: UTCTime 712 -> Config 713 -> UserPreferences 714 -> ClientChannels 715 -> [ChannelListEntry] 716getGroupDMChannelEntries now config prefs cs = 717 let matches (_, info) = info^.ccInfo.cdType == Group && 718 info^.ccInfo.cdTeamId == Nothing && 719 groupChannelShouldAppear now config prefs info 720 in fmap (\(cId, ch) -> ChannelListEntry { channelListEntryChannelId = cId 721 , channelListEntryType = CLGroupDM 722 , channelListEntryUnread = hasUnread' ch 723 , channelListEntrySortValue = ch^.ccInfo.cdDisplayName 724 , channelListEntryFavorite = isFavorite prefs cId 725 }) $ 726 filteredChannels matches cs 727 728getSingleDMChannelEntries :: UTCTime 729 -> Config 730 -> Maybe ClientConfig 731 -> UserPreferences 732 -> Users 733 -> ClientChannels 734 -> [ChannelListEntry] 735getSingleDMChannelEntries now config cconfig prefs us cs = 736 let mapping = allDmChannelMappings cs 737 mappingWithUserInfo = catMaybes $ getInfo <$> mapping 738 getInfo (uId, cId) = do 739 c <- findChannelById cId cs 740 u <- findUserById uId us 741 case u^.uiDeleted of 742 True -> Nothing 743 False -> 744 if dmChannelShouldAppear now config prefs c 745 then return (ChannelListEntry { channelListEntryChannelId = cId 746 , channelListEntryType = CLUserDM uId 747 , channelListEntryUnread = hasUnread' c 748 , channelListEntrySortValue = displayNameForUser u cconfig prefs 749 , channelListEntryFavorite = isFavorite prefs cId 750 }) 751 else Nothing 752 in mappingWithUserInfo 753 754-- | Return whether the specified channel has been marked as a favorite 755-- channel. 756isFavorite :: UserPreferences -> ChannelId -> Bool 757isFavorite prefs cId = favoriteChannelPreference prefs cId == Just True 758 759-- Always show a DM channel if it has unread activity or has been marked 760-- as a favorite. 761-- 762-- If it has no unread activity and if the preferences explicitly say to 763-- hide it, hide it. 764-- 765-- Otherwise, only show it if at least one of the other conditions are 766-- met (see 'or' below). 767dmChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool 768dmChannelShouldAppear now config prefs c = 769 let ndays = configDirectChannelExpirationDays config 770 localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now 771 cutoff = ServerTime localCutoff 772 updated = c^.ccInfo.cdUpdated 773 Just uId = c^.ccInfo.cdDMUserId 774 cId = c^.ccInfo.cdChannelId 775 in if isFavorite prefs cId 776 then True 777 else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) 778 then True 779 else case dmChannelShowPreference prefs uId of 780 Just False -> False 781 _ -> or [ 782 -- The channel was updated recently enough 783 updated >= cutoff 784 ]) 785 786-- Always show a group DM channel if it has unread activity or has been 787-- marked as a favorite. 788-- 789-- If it has no unread activity and if the preferences explicitly say to 790-- hide it, hide it. 791-- 792-- Otherwise, only show it if at least one of the other conditions are 793-- met (see 'or' below). 794groupChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool 795groupChannelShouldAppear now config prefs c = 796 let ndays = configDirectChannelExpirationDays config 797 localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now 798 cutoff = ServerTime localCutoff 799 updated = c^.ccInfo.cdUpdated 800 cId = c^.ccInfo.cdChannelId 801 in if isFavorite prefs cId 802 then True 803 else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) 804 then True 805 else case groupChannelShowPreference prefs cId of 806 Just False -> False 807 _ -> or [ 808 -- The channel was updated recently enough 809 updated >= cutoff 810 ]) 811 812dmChannelShowPreference :: UserPreferences -> UserId -> Maybe Bool 813dmChannelShowPreference ps uId = HM.lookup uId (_userPrefDirectChannelPrefs ps) 814 815groupChannelShowPreference :: UserPreferences -> ChannelId -> Maybe Bool 816groupChannelShowPreference ps cId = HM.lookup cId (_userPrefGroupChannelPrefs ps) 817 818favoriteChannelPreference :: UserPreferences -> ChannelId -> Maybe Bool 819favoriteChannelPreference ps cId = HM.lookup cId (_userPrefFavoriteChannelPrefs ps) 820 821-- * Internal Names and References 822 823-- | This 'Name' type is the type used in 'brick' to identify various 824-- parts of the interface. 825data Name = 826 ChannelMessages ChannelId 827 | MessageInput TeamId 828 | ChannelList TeamId 829 | HelpViewport 830 | HelpText 831 | ScriptHelpText 832 | ThemeHelpText 833 | SyntaxHighlightHelpText 834 | KeybindingHelpText 835 | ChannelSelectString TeamId 836 | ChannelSelectEntry ChannelSelectMatch 837 | CompletionAlternatives TeamId 838 | CompletionList TeamId 839 | JoinChannelList TeamId 840 | UrlList TeamId 841 | MessagePreviewViewport TeamId 842 | ThemeListSearchInput TeamId 843 | UserListSearchInput TeamId 844 | JoinChannelListSearchInput TeamId 845 | UserListSearchResults TeamId 846 | ThemeListSearchResults TeamId 847 | ViewMessageArea TeamId 848 | ViewMessageReactionsArea TeamId 849 | ChannelSidebar TeamId 850 | ChannelSelectInput TeamId 851 | AttachmentList TeamId 852 | AttachmentFileBrowser TeamId 853 | MessageReactionsArea TeamId 854 | ReactionEmojiList TeamId 855 | ReactionEmojiListInput TeamId 856 | TabbedWindowTabBar TeamId 857 | MuteToggleField TeamId 858 | ChannelMentionsField TeamId 859 | DesktopNotificationsField TeamId (WithDefault NotifyOption) 860 | PushNotificationsField TeamId (WithDefault NotifyOption) 861 | ChannelTopicEditor TeamId 862 | ChannelTopicSaveButton TeamId 863 | ChannelTopicCancelButton TeamId 864 | ChannelTopicEditorPreview TeamId 865 | ChannelTopic 866 | TeamList 867 | ClickableChannelListEntry ChannelId 868 | ClickableTeamListEntry TeamId 869 | ClickableURL Name Int LinkTarget 870 | ClickableURLInMessage MessageId Int LinkTarget 871 | ClickableUsernameInMessage MessageId Int Text 872 | ClickableUsername Name Int Text 873 | ClickableURLListEntry Int LinkTarget 874 | ClickableReactionInMessage PostId Text (Set UserId) 875 | ClickableReaction PostId Text (Set UserId) 876 | AttachmentPathEditor TeamId 877 | AttachmentPathSaveButton TeamId 878 | AttachmentPathCancelButton TeamId 879 | RenderedMessage MessageId 880 | ReactionEmojiListOverlayEntry (Bool, T.Text) 881 deriving (Eq, Show, Ord) 882 883-- | Types that provide a "semantically equal" operation. Two values may 884-- be semantically equal even if they are not equal according to Eq if, 885-- for example, they are equal on the basis of some fields that are more 886-- pertinent than others. 887class (Show a, Eq a, Ord a) => SemEq a where 888 semeq :: a -> a -> Bool 889 890instance SemEq Name where 891 semeq (ClickableURLInMessage mId1 _ t1) (ClickableURLInMessage mId2 _ t2) = mId1 == mId2 && t1 == t2 892 semeq (ClickableUsernameInMessage mId1 _ n) (ClickableUsernameInMessage mId2 _ n2) = mId1 == mId2 && n == n2 893 semeq a b = a == b 894 895instance SemEq a => SemEq (Maybe a) where 896 semeq Nothing Nothing = True 897 semeq (Just a) (Just b) = a `semeq` b 898 semeq _ _ = False 899 900-- | The sum type of exceptions we expect to encounter on authentication 901-- failure. We encode them explicitly here so that we can print them in 902-- a more user-friendly manner than just 'show'. 903data AuthenticationException = 904 ConnectError HostCannotConnect 905 | ResolveError HostNotResolved 906 | AuthIOError IOError 907 | LoginError LoginFailureException 908 | OtherAuthError SomeException 909 deriving (Show) 910 911-- | Our 'ConnectionInfo' contains exactly as much information as is 912-- necessary to start a connection with a Mattermost server. This is 913-- built up during interactive authentication and then is used to log 914-- in. 915-- 916-- If the access token field is non-empty, that value is used and the 917-- username and password values are ignored. 918data ConnectionInfo = 919 ConnectionInfo { _ciHostname :: Text 920 , _ciPort :: Int 921 , _ciUrlPath :: Text 922 , _ciUsername :: Text 923 , _ciPassword :: Text 924 , _ciAccessToken :: Text 925 , _ciType :: ConnectionType 926 } 927 928-- | We want to continue referring to posts by their IDs, but we don't 929-- want to have to synthesize new valid IDs for messages from the client 930-- itself (like error messages or informative client responses). To that 931-- end, a PostRef can be either a PostId or a newly-generated client ID. 932data PostRef 933 = MMId PostId 934 | CLId Int 935 deriving (Eq, Show) 936 937-- ** Channel-matching types 938 939-- | A match in channel selection mode. 940data ChannelSelectMatch = 941 ChannelSelectMatch { nameBefore :: Text 942 -- ^ The content of the match before the user's 943 -- matching input. 944 , nameMatched :: Text 945 -- ^ The potion of the name that matched the 946 -- user's input. 947 , nameAfter :: Text 948 -- ^ The portion of the name that came after the 949 -- user's matching input. 950 , matchFull :: Text 951 -- ^ The full string for this entry so it doesn't 952 -- have to be reassembled from the parts above. 953 , matchEntry :: ChannelListEntry 954 -- ^ The original entry data corresponding to the 955 -- text match. 956 } 957 deriving (Eq, Show, Ord) 958 959data ChannelSelectPattern = CSP MatchType Text 960 | CSPAny 961 deriving (Eq, Show) 962 963data MatchType = 964 Prefix 965 | Suffix 966 | Infix 967 | Equal 968 | PrefixDMOnly 969 | PrefixNonDMOnly 970 deriving (Eq, Show) 971 972-- * Application State Values 973 974data ProgramOutput = 975 ProgramOutput { program :: FilePath 976 , programArgs :: [String] 977 , programStdout :: String 978 , programStderr :: String 979 , programExitCode :: ExitCode 980 } 981 982defaultUserPreferences :: UserPreferences 983defaultUserPreferences = 984 UserPreferences { _userPrefShowJoinLeave = True 985 , _userPrefFlaggedPostList = mempty 986 , _userPrefGroupChannelPrefs = mempty 987 , _userPrefDirectChannelPrefs = mempty 988 , _userPrefFavoriteChannelPrefs = mempty 989 , _userPrefTeammateNameDisplayMode = Nothing 990 , _userPrefTeamOrder = Nothing 991 } 992 993setUserPreferences :: Seq Preference -> UserPreferences -> UserPreferences 994setUserPreferences = flip (F.foldr go) 995 where go p u 996 | Just fp <- preferenceToFlaggedPost p = 997 u { _userPrefFlaggedPostList = 998 _userPrefFlaggedPostList u Seq.|> fp 999 } 1000 | Just gp <- preferenceToDirectChannelShowStatus p = 1001 u { _userPrefDirectChannelPrefs = 1002 HM.insert 1003 (directChannelShowUserId gp) 1004 (directChannelShowValue gp) 1005 (_userPrefDirectChannelPrefs u) 1006 } 1007 | Just gp <- preferenceToGroupChannelPreference p = 1008 u { _userPrefGroupChannelPrefs = 1009 HM.insert 1010 (groupChannelId gp) 1011 (groupChannelShow gp) 1012 (_userPrefGroupChannelPrefs u) 1013 } 1014 | Just fp <- preferenceToFavoriteChannelPreference p = 1015 u { _userPrefFavoriteChannelPrefs = 1016 HM.insert 1017 (favoriteChannelId fp) 1018 (favoriteChannelShow fp) 1019 (_userPrefFavoriteChannelPrefs u) 1020 } 1021 | Just tIds <- preferenceToTeamOrder p = 1022 u { _userPrefTeamOrder = Just tIds 1023 } 1024 | preferenceName p == PreferenceName "join_leave" = 1025 u { _userPrefShowJoinLeave = 1026 preferenceValue p /= PreferenceValue "false" } 1027 | preferenceCategory p == PreferenceCategoryDisplaySettings && 1028 preferenceName p == PreferenceName "name_format" = 1029 let PreferenceValue txt = preferenceValue p 1030 in u { _userPrefTeammateNameDisplayMode = Just $ teammateDisplayModeFromText txt } 1031 | otherwise = u 1032 1033-- | Log message tags. 1034data LogCategory = 1035 LogGeneral 1036 | LogAPI 1037 | LogWebsocket 1038 | LogError 1039 | LogUserMark 1040 deriving (Eq, Show) 1041 1042-- | A log message. 1043data LogMessage = 1044 LogMessage { logMessageText :: !Text 1045 -- ^ The text of the log message. 1046 , logMessageContext :: !(Maybe LogContext) 1047 -- ^ The optional context information relevant to the log 1048 -- message. 1049 , logMessageCategory :: !LogCategory 1050 -- ^ The category of the log message. 1051 , logMessageTimestamp :: !UTCTime 1052 -- ^ The timestamp of the log message. 1053 } 1054 deriving (Eq, Show) 1055 1056-- | A logging thread command. 1057data LogCommand = 1058 LogToFile FilePath 1059 -- ^ Start logging to the specified path. 1060 | LogAMessage !LogMessage 1061 -- ^ Log the specified message. 1062 | StopLogging 1063 -- ^ Stop any active logging. 1064 | ShutdownLogging 1065 -- ^ Shut down. 1066 | GetLogDestination 1067 -- ^ Ask the logging thread about its active logging destination. 1068 | LogSnapshot FilePath 1069 -- ^ Ask the logging thread to dump the current buffer to the 1070 -- specified destination. 1071 deriving (Show) 1072 1073-- | A handle to the log manager thread. 1074data LogManager = 1075 LogManager { logManagerCommandChannel :: STM.TChan LogCommand 1076 , logManagerHandle :: Async () 1077 } 1078 1079startLoggingToFile :: LogManager -> FilePath -> IO () 1080startLoggingToFile mgr loc = sendLogCommand mgr $ LogToFile loc 1081 1082stopLoggingToFile :: LogManager -> IO () 1083stopLoggingToFile mgr = sendLogCommand mgr StopLogging 1084 1085requestLogSnapshot :: LogManager -> FilePath -> IO () 1086requestLogSnapshot mgr path = sendLogCommand mgr $ LogSnapshot path 1087 1088requestLogDestination :: LogManager -> IO () 1089requestLogDestination mgr = sendLogCommand mgr GetLogDestination 1090 1091sendLogMessage :: LogManager -> LogMessage -> IO () 1092sendLogMessage mgr lm = sendLogCommand mgr $ LogAMessage lm 1093 1094sendLogCommand :: LogManager -> LogCommand -> IO () 1095sendLogCommand mgr c = 1096 STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) c 1097 1098-- | 'ChatResources' represents configuration and connection-related 1099-- information, as opposed to current model or view information. 1100-- Information that goes in the 'ChatResources' value should be limited 1101-- to information that we read or set up prior to setting up the bulk of 1102-- the application state. 1103data ChatResources = 1104 ChatResources { _crSession :: Session 1105 , _crWebsocketThreadId :: Maybe ThreadId 1106 , _crConn :: ConnectionData 1107 , _crRequestQueue :: RequestChan 1108 , _crEventQueue :: BCH.BChan MHEvent 1109 , _crSubprocessLog :: STM.TChan ProgramOutput 1110 , _crWebsocketActionChan :: STM.TChan WebsocketAction 1111 , _crTheme :: AttrMap 1112 , _crStatusUpdateChan :: STM.TChan [UserId] 1113 , _crConfiguration :: Config 1114 , _crFlaggedPosts :: Set PostId 1115 , _crUserPreferences :: UserPreferences 1116 , _crSyntaxMap :: SyntaxMap 1117 , _crLogManager :: LogManager 1118 , _crEmoji :: EmojiCollection 1119 } 1120 1121-- | A "special" mention that does not map to a specific user, but is an 1122-- alias that the server uses to notify users. 1123data SpecialMention = 1124 MentionAll 1125 -- ^ @all: notify everyone in the channel. 1126 | MentionChannel 1127 -- ^ @channel: notify everyone in the channel. 1128 1129data AutocompleteAlternative = 1130 UserCompletion User Bool 1131 -- ^ User, plus whether the user is in the channel that triggered 1132 -- the autocomplete 1133 | SpecialMention SpecialMention 1134 -- ^ A special mention. 1135 | ChannelCompletion Bool Channel 1136 -- ^ Channel, plus whether the user is a member of the channel 1137 | SyntaxCompletion Text 1138 -- ^ Name of a skylighting syntax definition 1139 | CommandCompletion CompletionSource Text Text Text 1140 -- ^ Source, name of a slash command, argspec, and description 1141 | EmojiCompletion Text 1142 -- ^ The text of an emoji completion 1143 1144-- | The source of an autocompletion alternative. 1145data CompletionSource = Server | Client 1146 deriving (Eq, Show) 1147 1148specialMentionName :: SpecialMention -> Text 1149specialMentionName MentionChannel = "channel" 1150specialMentionName MentionAll = "all" 1151 1152isSpecialMention :: T.Text -> Bool 1153isSpecialMention n = isJust $ lookup (T.toLower $ trimUserSigil n) pairs 1154 where 1155 pairs = mkPair <$> mentions 1156 mentions = [ MentionChannel 1157 , MentionAll 1158 ] 1159 mkPair v = (specialMentionName v, v) 1160 1161autocompleteAlternativeReplacement :: AutocompleteAlternative -> Text 1162autocompleteAlternativeReplacement (EmojiCompletion e) = 1163 ":" <> e <> ":" 1164autocompleteAlternativeReplacement (SpecialMention m) = 1165 userSigil <> specialMentionName m 1166autocompleteAlternativeReplacement (UserCompletion u _) = 1167 userSigil <> userUsername u 1168autocompleteAlternativeReplacement (ChannelCompletion _ c) = 1169 normalChannelSigil <> (sanitizeUserText $ channelName c) 1170autocompleteAlternativeReplacement (SyntaxCompletion t) = 1171 "```" <> t 1172autocompleteAlternativeReplacement (CommandCompletion _ t _ _) = 1173 "/" <> t 1174 1175-- | The type of data that the autocompletion logic supports. We use 1176-- this to track the kind of completion underway in case the type of 1177-- completion needs to change. 1178data AutocompletionType = 1179 ACUsers 1180 | ACChannels 1181 | ACCodeBlockLanguage 1182 | ACEmoji 1183 | ACCommands 1184 deriving (Eq, Show) 1185 1186data AutocompleteState = 1187 AutocompleteState { _acPreviousSearchString :: Text 1188 -- ^ The search string used for the 1189 -- currently-displayed autocomplete results, for 1190 -- use in deciding whether to issue another server 1191 -- query 1192 , _acCompletionList :: List Name AutocompleteAlternative 1193 -- ^ The list of alternatives that the user 1194 -- selects from 1195 , _acType :: AutocompletionType 1196 -- ^ The type of data that we're completing 1197 , _acCachedResponses :: HM.HashMap Text [AutocompleteAlternative] 1198 -- ^ A cache of alternative lists, keyed on search 1199 -- string, for use in avoiding server requests. 1200 -- The idea here is that users type quickly enough 1201 -- (and edit their input) that would normally lead 1202 -- to rapid consecutive requests, some for the 1203 -- same strings during editing, that we can avoid 1204 -- that by caching them here. Note that this cache 1205 -- gets destroyed whenever autocompletion is not 1206 -- on, so this cache does not live very long. 1207 } 1208 1209-- | The 'ChatEditState' value contains the editor widget itself as well 1210-- as history and metadata we need for editing-related operations. 1211data ChatEditState = 1212 ChatEditState { _cedEditor :: Editor Text Name 1213 , _cedEditMode :: EditMode 1214 , _cedEphemeral :: EphemeralEditState 1215 , _cedYankBuffer :: Text 1216 , _cedSpellChecker :: Maybe (Aspell, IO ()) 1217 , _cedMisspellings :: Set Text 1218 , _cedAutocomplete :: Maybe AutocompleteState 1219 -- ^ The autocomplete state. The autocompletion UI is 1220 -- showing only when this state is present. 1221 , _cedAutocompletePending :: Maybe Text 1222 -- ^ The search string associated with the latest 1223 -- in-flight autocompletion request. This is used to 1224 -- determine whether any (potentially late-arriving) 1225 -- API responses are for stale queries since the user 1226 -- can type more quickly than the server can get us 1227 -- the results, and we wouldn't want to show results 1228 -- associated with old editor states. 1229 , _cedAttachmentList :: List Name AttachmentData 1230 -- ^ The list of attachments to be uploaded with the 1231 -- post being edited. 1232 , _cedFileBrowser :: Maybe (FB.FileBrowser Name) 1233 -- ^ The browser for selecting attachment files. 1234 -- This is a Maybe because the instantiation of the 1235 -- FileBrowser causes it to read and ingest the 1236 -- target directory, so this action is deferred 1237 -- until the browser is needed. 1238 , _cedJustCompleted :: Bool 1239 -- A flag that indicates whether the most recent 1240 -- editing event was a tab-completion. This is used by 1241 -- the smart trailing space handling. 1242 } 1243 1244-- | An attachment. 1245data AttachmentData = 1246 AttachmentData { attachmentDataFileInfo :: FB.FileInfo 1247 , attachmentDataBytes :: BS.ByteString 1248 } 1249 deriving (Eq, Show) 1250 1251-- | We can initialize a new 'ChatEditState' value with just an edit 1252-- history, which we save locally. 1253emptyEditState :: TeamId -> ChatEditState 1254emptyEditState tId = 1255 ChatEditState { _cedEditor = editor (MessageInput tId) Nothing "" 1256 , _cedEphemeral = defaultEphemeralEditState 1257 , _cedEditMode = NewPost 1258 , _cedYankBuffer = "" 1259 , _cedSpellChecker = Nothing 1260 , _cedMisspellings = mempty 1261 , _cedAutocomplete = Nothing 1262 , _cedAutocompletePending = Nothing 1263 , _cedAttachmentList = list (AttachmentList tId) mempty 1 1264 , _cedFileBrowser = Nothing 1265 , _cedJustCompleted = False 1266 } 1267 1268-- | A 'RequestChan' is a queue of operations we have to perform in the 1269-- background to avoid blocking on the main loop 1270type RequestChan = STM.TChan (IO (Maybe (MH ()))) 1271 1272-- | The 'HelpScreen' type represents the set of possible 'Help' 1273-- dialogues we have to choose from. 1274data HelpScreen = 1275 MainHelp 1276 | ScriptHelp 1277 | ThemeHelp 1278 | SyntaxHighlightHelp 1279 | KeybindingHelp 1280 deriving (Eq) 1281 1282-- | Help topics 1283data HelpTopic = 1284 HelpTopic { helpTopicName :: Text 1285 , helpTopicDescription :: Text 1286 , helpTopicScreen :: HelpScreen 1287 , helpTopicViewportName :: Name 1288 } 1289 deriving (Eq) 1290 1291-- | Mode type for the current contents of the post list overlay 1292data PostListContents = 1293 PostListFlagged 1294 | PostListPinned ChannelId 1295 | PostListSearch Text Bool -- for the query and search status 1296 deriving (Eq) 1297 1298-- | The 'Mode' represents the current dominant UI activity 1299data Mode = 1300 Main 1301 | ShowHelp HelpTopic Mode 1302 | ChannelSelect 1303 | UrlSelect 1304 | LeaveChannelConfirm 1305 | DeleteChannelConfirm 1306 | MessageSelect 1307 | MessageSelectDeleteConfirm 1308 | PostListOverlay PostListContents 1309 | UserListOverlay 1310 | ReactionEmojiListOverlay 1311 | ChannelListOverlay 1312 | ThemeListOverlay 1313 | ViewMessage 1314 | ManageAttachments 1315 | ManageAttachmentsBrowseFiles 1316 | EditNotifyPrefs 1317 | ChannelTopicWindow 1318 | SaveAttachmentWindow LinkChoice 1319 deriving (Eq) 1320 1321-- | We're either connected or we're not. 1322data ConnectionStatus = Connected | Disconnected deriving (Eq) 1323 1324-- | An entry in a tabbed window corresponding to a tab and its content. 1325-- Parameterized over an abstract handle type ('a') for the tabs so we 1326-- can give each a unique handle. 1327data TabbedWindowEntry a = 1328 TabbedWindowEntry { tweValue :: a 1329 -- ^ The handle for this tab. 1330 , tweRender :: a -> ChatState -> Widget Name 1331 -- ^ The rendering function to use when this tab 1332 -- is selected. 1333 , tweHandleEvent :: a -> Vty.Event -> MH () 1334 -- ^ The event-handling function to use when this 1335 -- tab is selected. 1336 , tweTitle :: a -> Bool -> T.Text 1337 -- ^ Title function for this tab, with a boolean 1338 -- indicating whether this is the current tab. 1339 , tweShowHandler :: a -> MH () 1340 -- ^ A handler to be invoked when this tab is 1341 -- shown. 1342 } 1343 1344-- | The definition of a tabbed window. Note that this does not track 1345-- the *state* of the window; it merely provides a collection of tab 1346-- window entries (see above). To track the state of a tabbed window, 1347-- use a TabbedWindow. 1348-- 1349-- Parameterized over an abstract handle type ('a') for the tabs so we 1350-- can give each a unique handle. 1351data TabbedWindowTemplate a = 1352 TabbedWindowTemplate { twtEntries :: [TabbedWindowEntry a] 1353 -- ^ The entries in tabbed windows with this 1354 -- structure. 1355 , twtTitle :: a -> Widget Name 1356 -- ^ The title-rendering function for this kind 1357 -- of tabbed window. 1358 } 1359 1360-- | An instantiated tab window. This is based on a template and tracks 1361-- the state of the tabbed window (current tab). 1362-- 1363-- Parameterized over an abstract handle type ('a') for the tabs so we 1364-- can give each a unique handle. 1365data TabbedWindow a = 1366 TabbedWindow { twValue :: a 1367 -- ^ The handle of the currently-selected tab. 1368 , twReturnMode :: Mode 1369 -- ^ The mode to return to when the tab is closed. 1370 , twTemplate :: TabbedWindowTemplate a 1371 -- ^ The template to use as a basis for rendering the 1372 -- window and handling user input. 1373 , twWindowWidth :: Int 1374 , twWindowHeight :: Int 1375 -- ^ Window dimensions 1376 } 1377 1378-- | Construct a new tabbed window from a template. This will raise an 1379-- exception if the initially-selected tab does not exist in the window 1380-- template, or if the window template has any duplicated tab handles. 1381-- 1382-- Note that the caller is responsible for determining whether to call 1383-- the initially-selected tab's on-show handler. 1384tabbedWindow :: (Show a, Eq a) 1385 => a 1386 -- ^ The handle corresponding to the tab that should be 1387 -- selected initially. 1388 -> TabbedWindowTemplate a 1389 -- ^ The template for the window to construct. 1390 -> Mode 1391 -- ^ When the window is closed, return to this application 1392 -- mode. 1393 -> (Int, Int) 1394 -- ^ The window dimensions (width, height). 1395 -> TabbedWindow a 1396tabbedWindow initialVal t retMode (width, height) = 1397 let handles = tweValue <$> twtEntries t 1398 in if | null handles -> 1399 error "BUG: tabbed window template must provide at least one entry" 1400 | length handles /= length (nub handles) -> 1401 error "BUG: tabbed window should have one entry per handle" 1402 | not (initialVal `elem` handles) -> 1403 error $ "BUG: tabbed window handle " <> 1404 show initialVal <> " not present in template" 1405 | otherwise -> 1406 TabbedWindow { twTemplate = t 1407 , twValue = initialVal 1408 , twReturnMode = retMode 1409 , twWindowWidth = width 1410 , twWindowHeight = height 1411 } 1412 1413-- | Get the currently-selected tab entry for a tabbed window. Raise 1414-- an exception if the window's selected tab handle is not found in its 1415-- template (which is a bug in the tabbed window infrastructure). 1416getCurrentTabbedWindowEntry :: (Show a, Eq a) 1417 => TabbedWindow a 1418 -> TabbedWindowEntry a 1419getCurrentTabbedWindowEntry w = 1420 lookupTabbedWindowEntry (twValue w) w 1421 1422-- | Run the on-show handler for the window tab entry with the specified 1423-- handle. 1424runTabShowHandlerFor :: (Eq a, Show a) => a -> TabbedWindow a -> MH () 1425runTabShowHandlerFor handle w = do 1426 let entry = lookupTabbedWindowEntry handle w 1427 tweShowHandler entry handle 1428 1429-- | Look up a tabbed window entry by handle. Raises an exception if no 1430-- such entry exists. 1431lookupTabbedWindowEntry :: (Eq a, Show a) 1432 => a 1433 -> TabbedWindow a 1434 -> TabbedWindowEntry a 1435lookupTabbedWindowEntry handle w = 1436 let matchesVal e = tweValue e == handle 1437 in case filter matchesVal (twtEntries $ twTemplate w) of 1438 [e] -> e 1439 _ -> error $ "BUG: tabbed window entry for " <> show (twValue w) <> 1440 " should have matched a single entry" 1441 1442-- | Switch a tabbed window's selected tab to its next tab, cycling back 1443-- to the first tab if the last tab is the selected tab. This also 1444-- invokes the on-show handler for the newly-selected tab. 1445-- 1446-- Note that this does nothing if the window has only one tab. 1447tabbedWindowNextTab :: (Show a, Eq a) 1448 => TabbedWindow a 1449 -> MH (TabbedWindow a) 1450tabbedWindowNextTab w | length (twtEntries $ twTemplate w) == 1 = return w 1451tabbedWindowNextTab w = do 1452 let curIdx = case elemIndex (tweValue curEntry) allHandles of 1453 Nothing -> 1454 error $ "BUG: tabbedWindowNextTab: could not find " <> 1455 "current handle in handle list" 1456 Just i -> i 1457 nextIdx = if curIdx == length allHandles - 1 1458 then 0 1459 else curIdx + 1 1460 newHandle = allHandles !! nextIdx 1461 allHandles = tweValue <$> twtEntries (twTemplate w) 1462 curEntry = getCurrentTabbedWindowEntry w 1463 newWin = w { twValue = newHandle } 1464 1465 runTabShowHandlerFor newHandle newWin 1466 return newWin 1467 1468-- | Switch a tabbed window's selected tab to its previous tab, cycling 1469-- to the last tab if the first tab is the selected tab. This also 1470-- invokes the on-show handler for the newly-selected tab. 1471-- 1472-- Note that this does nothing if the window has only one tab. 1473tabbedWindowPreviousTab :: (Show a, Eq a) 1474 => TabbedWindow a 1475 -> MH (TabbedWindow a) 1476tabbedWindowPreviousTab w | length (twtEntries $ twTemplate w) == 1 = return w 1477tabbedWindowPreviousTab w = do 1478 let curIdx = case elemIndex (tweValue curEntry) allHandles of 1479 Nothing -> 1480 error $ "BUG: tabbedWindowPreviousTab: could not find " <> 1481 "current handle in handle list" 1482 Just i -> i 1483 nextIdx = if curIdx == 0 1484 then length allHandles - 1 1485 else curIdx - 1 1486 newHandle = allHandles !! nextIdx 1487 allHandles = tweValue <$> twtEntries (twTemplate w) 1488 curEntry = getCurrentTabbedWindowEntry w 1489 newWin = w { twValue = newHandle } 1490 1491 runTabShowHandlerFor newHandle newWin 1492 return newWin 1493 1494data ChannelListOrientation = 1495 ChannelListLeft 1496 -- ^ Show the channel list to the left of the message area. 1497 | ChannelListRight 1498 -- ^ Show the channel list to the right of the message area. 1499 deriving (Eq, Show) 1500 1501-- | This type represents the current state of our application at any 1502-- given time. 1503data ChatState = 1504 ChatState { _csResources :: ChatResources 1505 -- ^ Global application-wide resources that don't change 1506 -- much. 1507 , _csLastMouseDownEvent :: Maybe (Brick.BrickEvent Name MHEvent) 1508 -- ^ The most recent mouse click event we got. We reset 1509 -- this on mouse up so we can ignore clicks whenever this 1510 -- is already set. 1511 , _csTeams :: HashMap TeamId TeamState 1512 -- ^ The state for each team that we are in. 1513 , _csTeamZipper :: Z.Zipper () TeamId 1514 -- ^ The list of teams we can cycle through. 1515 , _csChannelListOrientation :: ChannelListOrientation 1516 -- ^ The orientation of the channel list. 1517 , _csMe :: User 1518 -- ^ The authenticated user. 1519 , _csChannels :: ClientChannels 1520 -- ^ The channels that we are showing, including their 1521 -- message lists. 1522 , _csPostMap :: HashMap PostId Message 1523 -- ^ The map of post IDs to messages. This allows us to 1524 -- access messages by ID without having to linearly scan 1525 -- channel message lists. 1526 , _csUsers :: Users 1527 -- ^ All of the users we know about. 1528 , _timeZone :: TimeZoneSeries 1529 -- ^ The client time zone. 1530 , _csConnectionStatus :: ConnectionStatus 1531 -- ^ Our view of the connection status. 1532 , _csWorkerIsBusy :: Maybe (Maybe Int) 1533 -- ^ Whether the async worker thread is busy, and its 1534 -- queue length if so. 1535 , _csClientConfig :: Maybe ClientConfig 1536 -- ^ The Mattermost client configuration, as we understand it. 1537 , _csInputHistory :: InputHistory 1538 -- ^ The map of per-channel input history for the 1539 -- application. We don't distribute the per-channel 1540 -- history into the per-channel states (like we do 1541 -- for other per-channel state) since keeping it 1542 -- under the InputHistory banner lets us use a nicer 1543 -- startup/shutdown disk file management API. 1544 } 1545 1546-- | All application state specific to a team, along with state specific 1547-- to our user interface's presentation of that team. We include the 1548-- UI state relevant to the team so that we can easily switch which 1549-- team the UI is presenting without having to reinitialize the UI from 1550-- the new team. This allows the user to be engaged in just about any 1551-- application activity while viewing a team, switch to another team, 1552-- and return to the original team and resume what they were doing, all 1553-- without us doing any work. 1554data TeamState = 1555 TeamState { _tsFocus :: Z.Zipper ChannelListGroup ChannelListEntry 1556 -- ^ The channel sidebar zipper that tracks which channel 1557 -- is selected. 1558 , _tsPendingChannelChange :: Maybe PendingChannelChange 1559 -- ^ A pending channel change that we need to apply once 1560 -- the channel in question is available. We set this up 1561 -- when we need to change to a channel in the sidebar, but 1562 -- it isn't even there yet because we haven't loaded its 1563 -- metadata. 1564 , _tsRecentChannel :: Maybe ChannelId 1565 -- ^ The most recently-selected channel, if any. 1566 , _tsReturnChannel :: Maybe ChannelId 1567 -- ^ The channel to return to after visiting one or more 1568 -- unread channels. 1569 , _tsEditState :: ChatEditState 1570 -- ^ The state of the input box used for composing and 1571 -- editing messages and commands. 1572 , _tsMessageSelect :: MessageSelectState 1573 -- ^ The state of message selection mode. 1574 , _tsTeam :: Team 1575 -- ^ The team data. 1576 , _tsChannelSelectState :: ChannelSelectState 1577 -- ^ The state of the user's input and selection for 1578 -- channel selection mode. 1579 , _tsUrlList :: List Name (Int, LinkChoice) 1580 -- ^ The URL list used to show URLs drawn from messages in 1581 -- a channel. 1582 , _tsViewedMessage :: Maybe (Message, TabbedWindow ViewMessageWindowTab) 1583 -- ^ Set when the ViewMessage mode is active. The message 1584 -- being viewed. Note that this stores a message, not 1585 -- a message ID. That's because not all messages have 1586 -- message IDs (e.g. client messages) and we still 1587 -- want to support viewing of those messages. It's the 1588 -- responsibility of code that uses this message to always 1589 -- consult the chat state for the latest *version* of any 1590 -- message with an ID here, to be sure that the latest 1591 -- version is used (e.g. if it gets edited, etc.). 1592 , _tsPostListOverlay :: PostListOverlayState 1593 -- ^ The state of the post list overlay. 1594 , _tsUserListOverlay :: ListOverlayState UserInfo UserSearchScope 1595 -- ^ The state of the user list overlay. 1596 , _tsChannelListOverlay :: ListOverlayState Channel ChannelSearchScope 1597 -- ^ The state of the user list overlay. 1598 , _tsNotifyPrefs :: Maybe (Form ChannelNotifyProps MHEvent Name) 1599 -- ^ A form for editing the notification preferences for 1600 -- the current channel. This is set when entering 1601 -- EditNotifyPrefs mode and updated when the user 1602 -- changes the form state. 1603 , _tsChannelTopicDialog :: ChannelTopicDialogState 1604 -- ^ The state for the interactive channel topic editor 1605 -- window. 1606 , _tsMode :: Mode 1607 -- ^ The current application mode when viewing this team. 1608 -- This is used to dispatch to different rendering and 1609 -- event handling routines. 1610 , _tsReactionEmojiListOverlay :: ListOverlayState (Bool, T.Text) () 1611 -- ^ The state of the reaction emoji list overlay. 1612 , _tsThemeListOverlay :: ListOverlayState InternalTheme () 1613 -- ^ The state of the theme list overlay. 1614 , _tsSaveAttachmentDialog :: SaveAttachmentDialogState 1615 -- ^ The state for the interactive attachment-saving 1616 -- editor window. 1617 } 1618 1619-- | Handles for the View Message window's tabs. 1620data ViewMessageWindowTab = 1621 VMTabMessage 1622 -- ^ The message tab. 1623 | VMTabReactions 1624 -- ^ The reactions tab. 1625 deriving (Eq, Show) 1626 1627data PendingChannelChange = 1628 ChangeByChannelId TeamId ChannelId (Maybe (MH ())) 1629 | ChangeByUserId UserId 1630 1631-- | Startup state information that is constructed prior to building a 1632-- ChatState. 1633data StartupStateInfo = 1634 StartupStateInfo { startupStateResources :: ChatResources 1635 , startupStateConnectedUser :: User 1636 , startupStateTeams :: HM.HashMap TeamId TeamState 1637 , startupStateTimeZone :: TimeZoneSeries 1638 , startupStateInitialHistory :: InputHistory 1639 , startupStateInitialTeam :: TeamId 1640 } 1641 1642-- | The state of the channel topic editor window. 1643data ChannelTopicDialogState = 1644 ChannelTopicDialogState { _channelTopicDialogEditor :: Editor T.Text Name 1645 -- ^ The topic string editor state. 1646 , _channelTopicDialogFocus :: FocusRing Name 1647 -- ^ The window focus state (editor/buttons) 1648 } 1649 1650-- | The state of the attachment path window. 1651data SaveAttachmentDialogState = 1652 SaveAttachmentDialogState { _attachmentPathEditor :: Editor T.Text Name 1653 -- ^ The attachment path editor state. 1654 , _attachmentPathDialogFocus :: FocusRing Name 1655 -- ^ The window focus state (editor/buttons) 1656 } 1657 1658sortTeams :: [Team] -> [Team] 1659sortTeams = sortBy (compare `on` (T.strip . sanitizeUserText . teamName)) 1660 1661mkTeamZipper :: HM.HashMap TeamId TeamState -> Z.Zipper () TeamId 1662mkTeamZipper m = 1663 let sortedTeams = sortTeams $ _tsTeam <$> HM.elems m 1664 in mkTeamZipperFromIds $ teamId <$> sortedTeams 1665 1666mkTeamZipperFromIds :: [TeamId] -> Z.Zipper () TeamId 1667mkTeamZipperFromIds tIds = Z.fromList [((), tIds)] 1668 1669teamZipperIds :: Z.Zipper () TeamId -> [TeamId] 1670teamZipperIds = concat . fmap snd . Z.toList 1671 1672newTeamState :: Team 1673 -> Z.Zipper ChannelListGroup ChannelListEntry 1674 -> Maybe (Aspell, IO ()) 1675 -> TeamState 1676newTeamState team chanList spellChecker = 1677 let tId = teamId team 1678 in TeamState { _tsMode = Main 1679 , _tsFocus = chanList 1680 , _tsEditState = (emptyEditState tId) { _cedSpellChecker = spellChecker } 1681 , _tsTeam = team 1682 , _tsUrlList = list (UrlList tId) mempty 2 1683 , _tsPostListOverlay = PostListOverlayState emptyDirSeq Nothing 1684 , _tsUserListOverlay = nullUserListOverlayState tId 1685 , _tsChannelListOverlay = nullChannelListOverlayState tId 1686 , _tsChannelSelectState = emptyChannelSelectState tId 1687 , _tsChannelTopicDialog = newChannelTopicDialog tId "" 1688 , _tsMessageSelect = MessageSelectState Nothing 1689 , _tsNotifyPrefs = Nothing 1690 , _tsPendingChannelChange = Nothing 1691 , _tsRecentChannel = Nothing 1692 , _tsReturnChannel = Nothing 1693 , _tsViewedMessage = Nothing 1694 , _tsThemeListOverlay = nullThemeListOverlayState tId 1695 , _tsReactionEmojiListOverlay = nullEmojiListOverlayState tId 1696 , _tsSaveAttachmentDialog = newSaveAttachmentDialog tId "" 1697 } 1698 1699-- | Make a new channel topic editor window state. 1700newChannelTopicDialog :: TeamId -> T.Text -> ChannelTopicDialogState 1701newChannelTopicDialog tId t = 1702 ChannelTopicDialogState { _channelTopicDialogEditor = editor (ChannelTopicEditor tId) Nothing t 1703 , _channelTopicDialogFocus = focusRing [ ChannelTopicEditor tId 1704 , ChannelTopicSaveButton tId 1705 , ChannelTopicCancelButton tId 1706 ] 1707 } 1708 1709-- | Make a new attachment-saving editor window state. 1710newSaveAttachmentDialog :: TeamId -> T.Text -> SaveAttachmentDialogState 1711newSaveAttachmentDialog tId t = 1712 SaveAttachmentDialogState { _attachmentPathEditor = applyEdit Z2.gotoEOL $ 1713 editor (AttachmentPathEditor tId) (Just 1) t 1714 , _attachmentPathDialogFocus = focusRing [ AttachmentPathEditor tId 1715 , AttachmentPathSaveButton tId 1716 , AttachmentPathCancelButton tId 1717 ] 1718 } 1719 1720nullChannelListOverlayState :: TeamId -> ListOverlayState Channel ChannelSearchScope 1721nullChannelListOverlayState tId = 1722 let newList rs = list (JoinChannelList tId) rs 2 1723 in ListOverlayState { _listOverlaySearchResults = newList mempty 1724 , _listOverlaySearchInput = editor (JoinChannelListSearchInput tId) (Just 1) "" 1725 , _listOverlaySearchScope = AllChannels 1726 , _listOverlaySearching = False 1727 , _listOverlayEnterHandler = const $ return False 1728 , _listOverlayNewList = newList 1729 , _listOverlayFetchResults = const $ const $ const $ return mempty 1730 , _listOverlayRecordCount = Nothing 1731 , _listOverlayReturnMode = Main 1732 } 1733 1734nullThemeListOverlayState :: TeamId -> ListOverlayState InternalTheme () 1735nullThemeListOverlayState tId = 1736 let newList rs = list (ThemeListSearchResults tId) rs 3 1737 in ListOverlayState { _listOverlaySearchResults = newList mempty 1738 , _listOverlaySearchInput = editor (ThemeListSearchInput tId) (Just 1) "" 1739 , _listOverlaySearchScope = () 1740 , _listOverlaySearching = False 1741 , _listOverlayEnterHandler = const $ return False 1742 , _listOverlayNewList = newList 1743 , _listOverlayFetchResults = const $ const $ const $ return mempty 1744 , _listOverlayRecordCount = Nothing 1745 , _listOverlayReturnMode = Main 1746 } 1747 1748nullUserListOverlayState :: TeamId -> ListOverlayState UserInfo UserSearchScope 1749nullUserListOverlayState tId = 1750 let newList rs = list (UserListSearchResults tId) rs 1 1751 in ListOverlayState { _listOverlaySearchResults = newList mempty 1752 , _listOverlaySearchInput = editor (UserListSearchInput tId) (Just 1) "" 1753 , _listOverlaySearchScope = AllUsers Nothing 1754 , _listOverlaySearching = False 1755 , _listOverlayEnterHandler = const $ return False 1756 , _listOverlayNewList = newList 1757 , _listOverlayFetchResults = const $ const $ const $ return mempty 1758 , _listOverlayRecordCount = Nothing 1759 , _listOverlayReturnMode = Main 1760 } 1761 1762nullEmojiListOverlayState :: TeamId -> ListOverlayState (Bool, T.Text) () 1763nullEmojiListOverlayState tId = 1764 let newList rs = list (ReactionEmojiList tId) rs 1 1765 in ListOverlayState { _listOverlaySearchResults = newList mempty 1766 , _listOverlaySearchInput = editor (ReactionEmojiListInput tId) (Just 1) "" 1767 , _listOverlaySearchScope = () 1768 , _listOverlaySearching = False 1769 , _listOverlayEnterHandler = const $ return False 1770 , _listOverlayNewList = newList 1771 , _listOverlayFetchResults = const $ const $ const $ return mempty 1772 , _listOverlayRecordCount = Nothing 1773 , _listOverlayReturnMode = MessageSelect 1774 } 1775 1776-- | The state of channel selection mode. 1777data ChannelSelectState = 1778 ChannelSelectState { _channelSelectInput :: Editor Text Name 1779 , _channelSelectMatches :: Z.Zipper ChannelListGroup ChannelSelectMatch 1780 } 1781 1782emptyChannelSelectState :: TeamId -> ChannelSelectState 1783emptyChannelSelectState tId = 1784 ChannelSelectState { _channelSelectInput = editor (ChannelSelectInput tId) (Just 1) "" 1785 , _channelSelectMatches = Z.fromList [] 1786 } 1787 1788-- | The state of message selection mode. 1789data MessageSelectState = 1790 MessageSelectState { selectMessageId :: Maybe MessageId 1791 } 1792 1793-- | The state of the post list overlay. 1794data PostListOverlayState = 1795 PostListOverlayState { _postListPosts :: Messages 1796 , _postListSelected :: Maybe PostId 1797 } 1798 1799data InternalTheme = 1800 InternalTheme { internalThemeName :: Text 1801 , internalTheme :: Theme 1802 , internalThemeDesc :: Text 1803 } 1804 1805-- | The state of the search result list overlay. Type 'a' is the type 1806-- of data in the list. Type 'b' is the search scope type. 1807data ListOverlayState a b = 1808 ListOverlayState { _listOverlaySearchResults :: List Name a 1809 -- ^ The list of search results currently shown in 1810 -- the overlay. 1811 , _listOverlaySearchInput :: Editor Text Name 1812 -- ^ The editor for the overlay's search input. 1813 , _listOverlaySearchScope :: b 1814 -- ^ The overlay's current search scope. 1815 , _listOverlaySearching :: Bool 1816 -- ^ Whether a search is in progress (i.e. whether 1817 -- we are currently awaiting a response from a 1818 -- search query to the server). 1819 , _listOverlayEnterHandler :: a -> MH Bool 1820 -- ^ The handler to invoke on the selected element 1821 -- when the user presses Enter. 1822 , _listOverlayNewList :: Vec.Vector a -> List Name a 1823 -- ^ The function to build a new brick List from a 1824 -- vector of search results. 1825 , _listOverlayFetchResults :: b -> Session -> Text -> IO (Vec.Vector a) 1826 -- ^ The function to call to issue a search query 1827 -- to the server. 1828 , _listOverlayRecordCount :: Maybe Int 1829 -- ^ The total number of available records, if known. 1830 , _listOverlayReturnMode :: Mode 1831 -- ^ The mode to return to when the window closes. 1832 } 1833 1834-- | The scope for searching for users in a user list overlay. 1835data UserSearchScope = 1836 ChannelMembers ChannelId TeamId 1837 | ChannelNonMembers ChannelId TeamId 1838 | AllUsers (Maybe TeamId) 1839 1840-- | The scope for searching for channels to join. 1841data ChannelSearchScope = 1842 AllChannels 1843 1844-- | Actions that can be sent on the websocket to the server. 1845data WebsocketAction = 1846 UserTyping UTCTime ChannelId (Maybe PostId) -- ^ user typing in the input box 1847 deriving (Read, Show, Eq, Ord) 1848 1849-- * MH Monad 1850 1851-- | Logging context information, in the event that metadata should 1852-- accompany a log message. 1853data LogContext = 1854 LogContext { logContextChannelId :: Maybe ChannelId 1855 } 1856 deriving (Eq, Show) 1857 1858-- | A user fetching strategy. 1859data UserFetch = 1860 UserFetchById UserId 1861 -- ^ Fetch the user with the specified ID. 1862 | UserFetchByUsername Text 1863 -- ^ Fetch the user with the specified username. 1864 | UserFetchByNickname Text 1865 -- ^ Fetch the user with the specified nickname. 1866 deriving (Eq, Show) 1867 1868data MHState = 1869 MHState { mhCurrentState :: ChatState 1870 , mhNextAction :: ChatState -> EventM Name (Next ChatState) 1871 , mhUsersToFetch :: [UserFetch] 1872 , mhPendingStatusList :: Maybe [UserId] 1873 } 1874 1875-- | A value of type 'MH' @a@ represents a computation that can 1876-- manipulate the application state and also request that the 1877-- application quit 1878newtype MH a = 1879 MH { fromMH :: R.ReaderT (Maybe LogContext) (St.StateT MHState (EventM Name)) a } 1880 1881-- | Use a modified logging context for the duration of the specified MH 1882-- action. 1883withLogContext :: (Maybe LogContext -> Maybe LogContext) -> MH a -> MH a 1884withLogContext modifyContext act = 1885 MH $ R.withReaderT modifyContext (fromMH act) 1886 1887withLogContextChannelId :: ChannelId -> MH a -> MH a 1888withLogContextChannelId cId act = 1889 let f Nothing = Just $ LogContext (Just cId) 1890 f (Just c) = Just $ c { logContextChannelId = Just cId } 1891 in withLogContext f act 1892 1893-- | Get the current logging context. 1894getLogContext :: MH (Maybe LogContext) 1895getLogContext = MH R.ask 1896 1897-- | Log a message. 1898mhLog :: LogCategory -> Text -> MH () 1899mhLog cat msg = do 1900 logger <- mhGetIOLogger 1901 liftIO $ logger cat msg 1902 1903-- | Get a logger suitable for use in IO. The logger always logs using 1904-- the MH monad log context at the time of the call to mhGetIOLogger. 1905mhGetIOLogger :: MH (LogCategory -> Text -> IO ()) 1906mhGetIOLogger = do 1907 ctx <- getLogContext 1908 mgr <- use (to (_crLogManager . _csResources)) 1909 return $ ioLogWithManager mgr ctx 1910 1911ioLogWithManager :: LogManager -> Maybe LogContext -> LogCategory -> Text -> IO () 1912ioLogWithManager mgr ctx cat msg = do 1913 now <- getCurrentTime 1914 let lm = LogMessage { logMessageText = msg 1915 , logMessageContext = ctx 1916 , logMessageCategory = cat 1917 , logMessageTimestamp = now 1918 } 1919 sendLogMessage mgr lm 1920 1921-- | Run an 'MM' computation, choosing whether to continue or halt based 1922-- on the resulting 1923runMHEvent :: ChatState -> MH () -> EventM Name (Next ChatState) 1924runMHEvent st (MH mote) = do 1925 let mhSt = MHState { mhCurrentState = st 1926 , mhNextAction = Brick.continue 1927 , mhUsersToFetch = [] 1928 , mhPendingStatusList = Nothing 1929 } 1930 ((), st') <- St.runStateT (R.runReaderT mote Nothing) mhSt 1931 (mhNextAction st') (mhCurrentState st') 1932 1933scheduleUserFetches :: [UserFetch] -> MH () 1934scheduleUserFetches fs = MH $ do 1935 St.modify $ \s -> s { mhUsersToFetch = fs <> mhUsersToFetch s } 1936 1937scheduleUserStatusFetches :: [UserId] -> MH () 1938scheduleUserStatusFetches is = MH $ do 1939 St.modify $ \s -> s { mhPendingStatusList = Just is } 1940 1941getScheduledUserFetches :: MH [UserFetch] 1942getScheduledUserFetches = MH $ St.gets mhUsersToFetch 1943 1944getScheduledUserStatusFetches :: MH (Maybe [UserId]) 1945getScheduledUserStatusFetches = MH $ St.gets mhPendingStatusList 1946 1947-- | lift a computation in 'EventM' into 'MH' 1948mh :: EventM Name a -> MH a 1949mh = MH . R.lift . St.lift 1950 1951generateUUID :: MH UUID 1952generateUUID = liftIO generateUUID_IO 1953 1954generateUUID_IO :: IO UUID 1955generateUUID_IO = randomIO 1956 1957mhHandleEventLensed :: Lens' ChatState b -> (e -> b -> EventM Name b) -> e -> MH () 1958mhHandleEventLensed ln f event = MH $ do 1959 s <- St.get 1960 let st = mhCurrentState s 1961 n <- R.lift $ St.lift $ f event (st ^. ln) 1962 St.put (s { mhCurrentState = st & ln .~ n }) 1963 1964mhHandleEventLensed' :: Lens' ChatState b -> (b -> EventM Name b) -> MH () 1965mhHandleEventLensed' ln f = MH $ do 1966 s <- St.get 1967 let st = mhCurrentState s 1968 n <- R.lift $ St.lift $ f (st ^. ln) 1969 St.put (s { mhCurrentState = st & ln .~ n }) 1970 1971mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH () 1972mhSuspendAndResume mote = MH $ do 1973 s <- St.get 1974 St.put $ s { mhNextAction = \ _ -> Brick.suspendAndResume (mote $ mhCurrentState s) } 1975 1976-- | This will request that after this computation finishes the 1977-- application should exit 1978requestQuit :: MH () 1979requestQuit = MH $ do 1980 s <- St.get 1981 St.put $ s { mhNextAction = Brick.halt } 1982 1983instance Functor MH where 1984 fmap f (MH x) = MH (fmap f x) 1985 1986instance Applicative MH where 1987 pure x = MH (pure x) 1988 MH f <*> MH x = MH (f <*> x) 1989 1990instance MHF.MonadFail MH where 1991 fail = MH . MHF.fail 1992 1993instance Monad MH where 1994 return x = MH (return x) 1995 MH x >>= f = MH (x >>= \ x' -> fromMH (f x')) 1996 1997-- We want to pretend that the state is only the ChatState, rather 1998-- than the ChatState and the Brick continuation 1999instance St.MonadState ChatState MH where 2000 get = mhCurrentState `fmap` MH St.get 2001 put st = MH $ do 2002 s <- St.get 2003 St.put $ s { mhCurrentState = st } 2004 2005instance St.MonadIO MH where 2006 liftIO = MH . St.liftIO 2007 2008-- | This represents events that we handle in the main application loop. 2009data MHEvent = 2010 WSEvent WebsocketEvent 2011 -- ^ For events that arise from the websocket 2012 | WSActionResponse WebsocketActionResponse 2013 -- ^ For responses to websocket actions 2014 | RespEvent (MH ()) 2015 -- ^ For the result values of async IO operations 2016 | RefreshWebsocketEvent 2017 -- ^ Tell our main loop to refresh the websocket connection 2018 | WebsocketParseError String 2019 -- ^ We failed to parse an incoming websocket event 2020 | WebsocketDisconnect 2021 -- ^ The websocket connection went down. 2022 | WebsocketConnect 2023 -- ^ The websocket connection came up. 2024 | BGIdle 2025 -- ^ background worker is idle 2026 | BGBusy (Maybe Int) 2027 -- ^ background worker is busy (with n requests) 2028 | RateLimitExceeded Int 2029 -- ^ A request initially failed due to a rate limit but will be 2030 -- retried if possible. The argument is the number of seconds in 2031 -- which the retry will be attempted. 2032 | RateLimitSettingsMissing 2033 -- ^ A request denied by a rate limit could not be retried because 2034 -- the response contained no rate limit metadata 2035 | RequestDropped 2036 -- ^ A request was reattempted due to a rate limit and was rate 2037 -- limited again 2038 | IEvent InternalEvent 2039 -- ^ MH-internal events 2040 2041-- | Internal application events. 2042data InternalEvent = 2043 DisplayError MHError 2044 -- ^ Some kind of application error occurred 2045 | LoggingStarted FilePath 2046 | LoggingStopped FilePath 2047 | LogStartFailed FilePath String 2048 | LogDestination (Maybe FilePath) 2049 | LogSnapshotSucceeded FilePath 2050 | LogSnapshotFailed FilePath String 2051 -- ^ Logging events from the logging thread 2052 2053-- | Application errors. 2054data MHError = 2055 GenericError T.Text 2056 -- ^ A generic error message constructor 2057 | NoSuchChannel T.Text 2058 -- ^ The specified channel does not exist 2059 | NoSuchUser T.Text 2060 -- ^ The specified user does not exist 2061 | AmbiguousName T.Text 2062 -- ^ The specified name matches both a user and a channel 2063 | ServerError MattermostError 2064 -- ^ A Mattermost server error occurred 2065 | ClipboardError T.Text 2066 -- ^ A problem occurred trying to deal with yanking or the system 2067 -- clipboard 2068 | ConfigOptionMissing T.Text 2069 -- ^ A missing config option is required to perform an operation 2070 | ProgramExecutionFailed T.Text T.Text 2071 -- ^ Args: program name, path to log file. A problem occurred when 2072 -- running the program. 2073 | NoSuchScript T.Text 2074 -- ^ The specified script was not found 2075 | NoSuchHelpTopic T.Text 2076 -- ^ The specified help topic was not found 2077 | AttachmentException SomeException 2078 -- ^ IO operations for attaching a file threw an exception 2079 | BadAttachmentPath T.Text 2080 -- ^ The specified file is either a directory or doesn't exist 2081 | AsyncErrEvent SomeException 2082 -- ^ For errors that arise in the course of async IO operations 2083 deriving (Show) 2084 2085-- ** Application State Lenses 2086 2087makeLenses ''ChatResources 2088makeLenses ''ChatState 2089makeLenses ''TeamState 2090makeLenses ''ChatEditState 2091makeLenses ''AutocompleteState 2092makeLenses ''PostListOverlayState 2093makeLenses ''ListOverlayState 2094makeLenses ''ChannelSelectState 2095makeLenses ''UserPreferences 2096makeLenses ''ConnectionInfo 2097makeLenses ''ChannelTopicDialogState 2098makeLenses ''SaveAttachmentDialogState 2099Brick.suffixLenses ''Config 2100 2101applyTeamOrderPref :: Maybe [TeamId] -> ChatState -> ChatState 2102applyTeamOrderPref Nothing st = st 2103applyTeamOrderPref (Just prefTIds) st = 2104 let teams = _csTeams st 2105 ourTids = HM.keys teams 2106 tIds = filter (`elem` ourTids) prefTIds 2107 curTId = st^.csCurrentTeamId 2108 unmentioned = filter (not . wasMentioned) $ HM.elems teams 2109 wasMentioned ts = (teamId $ _tsTeam ts) `elem` tIds 2110 zipperTids = tIds <> (teamId <$> sortTeams (_tsTeam <$> unmentioned)) 2111 in st { _csTeamZipper = (Z.findRight (== curTId) $ mkTeamZipperFromIds zipperTids) 2112 } 2113 2114refreshTeamZipper :: MH () 2115refreshTeamZipper = do 2116 tidOrder <- use (csResources.crUserPreferences.userPrefTeamOrder) 2117 St.modify (applyTeamOrderPref tidOrder) 2118 2119applyTeamOrder :: [TeamId] -> MH () 2120applyTeamOrder tIds = St.modify (applyTeamOrderPref $ Just tIds) 2121 2122newState :: StartupStateInfo -> ChatState 2123newState (StartupStateInfo {..}) = 2124 let config = _crConfiguration startupStateResources 2125 in applyTeamOrderPref (_userPrefTeamOrder $ _crUserPreferences startupStateResources) $ 2126 ChatState { _csResources = startupStateResources 2127 , _csLastMouseDownEvent = Nothing 2128 , _csTeamZipper = Z.findRight (== startupStateInitialTeam) $ 2129 mkTeamZipper startupStateTeams 2130 , _csTeams = startupStateTeams 2131 , _csChannelListOrientation = configChannelListOrientation config 2132 , _csMe = startupStateConnectedUser 2133 , _csChannels = noChannels 2134 , _csPostMap = HM.empty 2135 , _csUsers = noUsers 2136 , _timeZone = startupStateTimeZone 2137 , _csConnectionStatus = Connected 2138 , _csWorkerIsBusy = Nothing 2139 , _csClientConfig = Nothing 2140 , _csInputHistory = startupStateInitialHistory 2141 } 2142 2143getServerBaseUrl :: TeamId -> MH TeamBaseURL 2144getServerBaseUrl tId = do 2145 st <- use id 2146 return $ serverBaseUrl st tId 2147 2148serverBaseUrl :: ChatState -> TeamId -> TeamBaseURL 2149serverBaseUrl st tId = 2150 let baseUrl = connectionDataURL $ _crConn $ _csResources st 2151 tName = teamName $ st^.csTeam(tId).tsTeam 2152 in TeamBaseURL (TeamURLName $ sanitizeUserText tName) baseUrl 2153 2154unsafeCedFileBrowser :: Lens' ChatEditState (FB.FileBrowser Name) 2155unsafeCedFileBrowser = 2156 lens (\st -> st^.cedFileBrowser ^?! _Just) 2157 (\st t -> st & cedFileBrowser .~ Just t) 2158 2159getSession :: MH Session 2160getSession = use (csResources.crSession) 2161 2162getResourceSession :: ChatResources -> Session 2163getResourceSession = _crSession 2164 2165whenMode :: Mode -> MH () -> MH () 2166whenMode m act = do 2167 curMode <- use (csCurrentTeam.tsMode) 2168 when (curMode == m) act 2169 2170setMode :: Mode -> MH () 2171setMode m = do 2172 csCurrentTeam.tsMode .= m 2173 mh invalidateCache 2174 2175setMode' :: Mode -> ChatState -> ChatState 2176setMode' m = csCurrentTeam.tsMode .~ m 2177 2178resetSpellCheckTimer :: ChatEditState -> IO () 2179resetSpellCheckTimer s = 2180 case s^.cedSpellChecker of 2181 Nothing -> return () 2182 Just (_, reset) -> reset 2183 2184-- ** Utility Lenses 2185csCurrentChannelId :: TeamId -> SimpleGetter ChatState ChannelId 2186csCurrentChannelId tId = 2187 csTeam(tId).tsFocus.to Z.unsafeFocus.to channelListEntryChannelId 2188 2189csCurrentTeamId :: SimpleGetter ChatState TeamId 2190csCurrentTeamId = 2191 csTeamZipper.to Z.unsafeFocus 2192 2193csCurrentTeam :: Lens' ChatState TeamState 2194csCurrentTeam = 2195 lens (\st -> st^.csTeam(st^.csCurrentTeamId)) 2196 (\st t -> st & csTeam(st^.csCurrentTeamId) .~ t) 2197 2198csTeam :: TeamId -> Lens' ChatState TeamState 2199csTeam tId = 2200 lens (\ st -> st ^. csTeams . at tId ^?! _Just) 2201 (\ st t -> st & csTeams . at tId .~ Just t) 2202 2203channelListEntryUserId :: ChannelListEntry -> Maybe UserId 2204channelListEntryUserId e = 2205 case channelListEntryType e of 2206 CLUserDM uId -> Just uId 2207 _ -> Nothing 2208 2209userIdsFromZipper :: Z.Zipper ChannelListGroup ChannelListEntry -> [UserId] 2210userIdsFromZipper z = 2211 concat $ (catMaybes . fmap channelListEntryUserId . snd) <$> Z.toList z 2212 2213entryIsDMEntry :: ChannelListEntry -> Bool 2214entryIsDMEntry e = 2215 case channelListEntryType e of 2216 CLUserDM {} -> True 2217 CLGroupDM {} -> True 2218 CLChannel {} -> False 2219 2220csCurrentChannel :: Lens' ChatState ClientChannel 2221csCurrentChannel = 2222 lens (\ st -> findChannelById (st^.csCurrentChannelId(st^.csCurrentTeamId)) (st^.csChannels) ^?! _Just) 2223 (\ st n -> st & csChannels %~ addChannel (st^.csCurrentChannelId(st^.csCurrentTeamId)) n) 2224 2225csChannel :: ChannelId -> Traversal' ChatState ClientChannel 2226csChannel cId = 2227 csChannels . channelByIdL cId 2228 2229withChannel :: ChannelId -> (ClientChannel -> MH ()) -> MH () 2230withChannel cId = withChannelOrDefault cId () 2231 2232withChannelOrDefault :: ChannelId -> a -> (ClientChannel -> MH a) -> MH a 2233withChannelOrDefault cId deflt mote = do 2234 chan <- preuse (csChannel(cId)) 2235 case chan of 2236 Nothing -> return deflt 2237 Just c -> mote c 2238 2239-- ** 'ChatState' Helper Functions 2240 2241raiseInternalEvent :: InternalEvent -> MH () 2242raiseInternalEvent ev = do 2243 queue <- use (csResources.crEventQueue) 2244 writeBChan queue (IEvent ev) 2245 2246writeBChan :: (MonadIO m) => BCH.BChan MHEvent -> MHEvent -> m () 2247writeBChan chan e = do 2248 written <- liftIO $ BCH.writeBChanNonBlocking chan e 2249 when (not written) $ 2250 error $ "mhSendEvent: BChan full, please report this as a bug!" 2251 2252-- | Log and raise an error. 2253mhError :: MHError -> MH () 2254mhError err = do 2255 mhLog LogError $ T.pack $ show err 2256 raiseInternalEvent (DisplayError err) 2257 2258isMine :: ChatState -> Message -> Bool 2259isMine st msg = 2260 case msg^.mUser of 2261 UserI _ uid -> uid == myUserId st 2262 _ -> False 2263 2264getMessageForPostId :: ChatState -> PostId -> Maybe Message 2265getMessageForPostId st pId = st^.csPostMap.at(pId) 2266 2267getParentMessage :: ChatState -> Message -> Maybe Message 2268getParentMessage st msg 2269 | InReplyTo pId <- msg^.mInReplyToMsg 2270 = st^.csPostMap.at(pId) 2271 | otherwise = Nothing 2272 2273getReplyRootMessage :: Message -> MH Message 2274getReplyRootMessage msg = do 2275 case postRootId =<< (msg^.mOriginalPost) of 2276 Nothing -> return msg 2277 Just rootId -> do 2278 st <- use id 2279 case getMessageForPostId st rootId of 2280 -- NOTE: this case should never happen. This is the 2281 -- case where a message has a root post ID but we 2282 -- don't have a copy of the root post in storage. This 2283 -- shouldn't happen because whenever we add a message 2284 -- to a channel, we always fetch the parent post and 2285 -- store it if it is in a thread. That should mean that 2286 -- whenever we reply to a post, if that post is itself 2287 -- a reply, we should have its root post in storage 2288 -- and this case should never match. Even though it 2289 -- shouldn't happen, rather than raising a BUG exception 2290 -- here we'll just fall back to the input message. 2291 Nothing -> return msg 2292 Just m -> return m 2293 2294setUserStatus :: UserId -> Text -> MH () 2295setUserStatus uId t = do 2296 csUsers %= modifyUserById uId (uiStatus .~ statusFromText t) 2297 cs <- use csChannels 2298 forM_ (allTeamIds cs) $ \tId -> 2299 mh $ invalidateCacheEntry $ ChannelSidebar tId 2300 2301usernameForUserId :: UserId -> ChatState -> Maybe Text 2302usernameForUserId uId st = _uiName <$> findUserById uId (st^.csUsers) 2303 2304displayNameForUserId :: UserId -> ChatState -> Maybe Text 2305displayNameForUserId uId st = do 2306 u <- findUserById uId (st^.csUsers) 2307 return $ displayNameForUser u (st^.csClientConfig) (st^.csResources.crUserPreferences) 2308 2309-- | Note: this only searches users we have already loaded. Be 2310-- aware that if you think you need a user we haven't fetched, use 2311-- withFetchedUser! 2312userIdForUsername :: Text -> ChatState -> Maybe UserId 2313userIdForUsername name st = 2314 fst <$> (findUserByUsername name $ st^.csUsers) 2315 2316channelIdByChannelName :: Text -> ChatState -> Maybe ChannelId 2317channelIdByChannelName name st = 2318 let matches (_, cc) = cc^.ccInfo.cdName == (trimChannelSigil name) && 2319 cc^.ccInfo.cdTeamId == (Just $ st^.csCurrentTeamId) 2320 in listToMaybe $ fst <$> filteredChannels matches (st^.csChannels) 2321 2322channelIdByUsername :: Text -> ChatState -> Maybe ChannelId 2323channelIdByUsername name st = do 2324 uId <- userIdForUsername name st 2325 getDmChannelFor uId (st^.csChannels) 2326 2327useNickname :: ChatState -> Bool 2328useNickname st = 2329 useNickname' (st^.csClientConfig) (st^.csResources.crUserPreferences) 2330 2331trimChannelSigil :: Text -> Text 2332trimChannelSigil n 2333 | normalChannelSigil `T.isPrefixOf` n = T.tail n 2334 | otherwise = n 2335 2336addNewUser :: UserInfo -> MH () 2337addNewUser u = do 2338 csUsers %= addUser u 2339 -- Invalidate the cache because channel message rendering may need 2340 -- to get updated if this user authored posts in any channels. 2341 mh invalidateCache 2342 2343data SidebarUpdate = 2344 SidebarUpdateImmediate 2345 | SidebarUpdateDeferred 2346 deriving (Eq, Show) 2347 2348 2349resetAutocomplete :: MH () 2350resetAutocomplete = do 2351 csCurrentTeam.tsEditState.cedAutocomplete .= Nothing 2352 csCurrentTeam.tsEditState.cedAutocompletePending .= Nothing 2353 2354 2355-- * Slash Commands 2356 2357-- | The 'CmdArgs' type represents the arguments to a slash-command; the 2358-- type parameter represents the argument structure. 2359data CmdArgs :: K.Type -> K.Type where 2360 NoArg :: CmdArgs () 2361 LineArg :: Text -> CmdArgs Text 2362 UserArg :: CmdArgs rest -> CmdArgs (Text, rest) 2363 ChannelArg :: CmdArgs rest -> CmdArgs (Text, rest) 2364 TokenArg :: Text -> CmdArgs rest -> CmdArgs (Text, rest) 2365 2366-- | A 'CmdExec' value represents the implementation of a command when 2367-- provided with its arguments 2368type CmdExec a = a -> MH () 2369 2370-- | A 'Cmd' packages up a 'CmdArgs' specifier and the 'CmdExec' 2371-- implementation with a name and a description. 2372data Cmd = 2373 forall a. Cmd { cmdName :: Text 2374 , cmdDescr :: Text 2375 , cmdArgSpec :: CmdArgs a 2376 , cmdAction :: CmdExec a 2377 } 2378 2379-- | Helper function to extract the name out of a 'Cmd' value 2380commandName :: Cmd -> Text 2381commandName (Cmd name _ _ _ ) = name 2382 2383-- * Channel Updates and Notifications 2384 2385userList :: ChatState -> [UserInfo] 2386userList st = filter showUser $ allUsers (st^.csUsers) 2387 where showUser u = not (isSelf u) && (u^.uiInTeam) 2388 isSelf u = (myUserId st) == (u^.uiId) 2389 2390allUserIds :: ChatState -> [UserId] 2391allUserIds st = getAllUserIds $ st^.csUsers 2392 2393-- BEWARE: you probably don't want this, but instead 2394-- State.Users.withFetchedUser, since this only looks up users in the 2395-- collection we have already loaded rather than all valid users on the 2396-- server. 2397userById :: UserId -> ChatState -> Maybe UserInfo 2398userById uId st = findUserById uId (st^.csUsers) 2399 2400myUserId :: ChatState -> UserId 2401myUserId st = myUser st ^. userIdL 2402 2403myUser :: ChatState -> User 2404myUser st = st^.csMe 2405 2406myUsername :: ChatState -> Text 2407myUsername st = userUsername $ st^.csMe 2408 2409-- BEWARE: you probably don't want this, but instead 2410-- State.Users.withFetchedUser, since this only looks up users in the 2411-- collection we have already loaded rather than all valid users on the 2412-- server. 2413userByUsername :: Text -> ChatState -> Maybe UserInfo 2414userByUsername name st = do 2415 snd <$> (findUserByUsername name $ st^.csUsers) 2416 2417-- BEWARE: you probably don't want this, but instead 2418-- State.Users.withFetchedUser, since this only looks up users in the 2419-- collection we have already loaded rather than all valid users on the 2420-- server. 2421userByNickname :: Text -> ChatState -> Maybe UserInfo 2422userByNickname name st = 2423 snd <$> (findUserByNickname name $ st^.csUsers) 2424 2425getUsers :: MH Users 2426getUsers = use csUsers 2427 2428-- * HighlightSet 2429 2430type UserSet = Set Text 2431type ChannelSet = Set Text 2432 2433-- | The set of usernames, channel names, and language names used for 2434-- highlighting when rendering messages. 2435data HighlightSet = 2436 HighlightSet { hUserSet :: Set Text 2437 , hChannelSet :: Set Text 2438 , hSyntaxMap :: SyntaxMap 2439 } 2440 2441emptyHSet :: HighlightSet 2442emptyHSet = HighlightSet Set.empty Set.empty mempty 2443 2444getHighlightSet :: ChatState -> HighlightSet 2445getHighlightSet st = 2446 let tId = st^.csCurrentTeamId 2447 in HighlightSet { hUserSet = addSpecialUserMentions $ getUsernameSet $ st^.csUsers 2448 , hChannelSet = getChannelNameSet tId $ st^.csChannels 2449 , hSyntaxMap = st^.csResources.crSyntaxMap 2450 } 2451 2452attrNameToConfig :: Brick.AttrName -> Text 2453attrNameToConfig = T.pack . intercalate "." . Brick.attrNameComponents 2454 2455-- From: https://docs.mattermost.com/help/messaging/mentioning-teammates.html 2456specialUserMentions :: [T.Text] 2457specialUserMentions = ["all", "channel", "here"] 2458 2459addSpecialUserMentions :: Set Text -> Set Text 2460addSpecialUserMentions s = foldr Set.insert s specialUserMentions 2461 2462getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator 2463getNewMessageCutoff cId st = do 2464 cc <- st^?csChannel(cId) 2465 return $ cc^.ccInfo.cdNewMessageIndicator 2466 2467getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe ServerTime 2468getEditedMessageCutoff cId st = do 2469 cc <- st^?csChannel(cId) 2470 cc^.ccInfo.cdEditedMessageThreshold 2471 2472clearChannelUnreadStatus :: ChannelId -> MH () 2473clearChannelUnreadStatus cId = do 2474 mh $ invalidateCacheEntry (ChannelMessages cId) 2475 csChannel(cId) %= (clearNewMessageIndicator . 2476 clearEditedThreshold) 2477 2478moveLeft :: (Eq a) => a -> [a] -> [a] 2479moveLeft v as = 2480 case elemIndex v as of 2481 Nothing -> as 2482 Just 0 -> as 2483 Just i -> 2484 let (h, t) = splitAt i as 2485 in init h <> [v, last h] <> tail t 2486 2487moveRight :: (Eq a) => a -> [a] -> [a] 2488moveRight v as = 2489 case elemIndex v as of 2490 Nothing -> as 2491 Just i 2492 | i == length as - 1 -> as 2493 | otherwise -> 2494 let (h, t) = splitAt i as 2495 in h <> [head (tail t), v] <> (tail (tail t)) 2496