{-# LANGUAGE TypeFamilies #-}
module Matterhorn.State.Setup
  ( setupState
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Brick.BChan ( newBChan )
import           Brick.Themes ( themeToAttrMap, loadCustomizations )
import qualified Control.Concurrent.STM as STM
import           Data.Either ( fromRight )
import qualified Data.Foldable as F
import qualified Data.HashMap.Strict as HM
import           Data.Maybe ( fromJust )
import qualified Data.Text as T
import           Data.Time.Clock ( getCurrentTime )
import qualified Graphics.Vty as Vty
import           Lens.Micro.Platform ( (.~) )
import           System.Exit ( exitFailure, exitSuccess )
import           System.FilePath ( (</>), isRelative, dropFileName )

import           Network.Mattermost.Endpoints
import           Network.Mattermost.Types

import           Matterhorn.Config
import           Matterhorn.InputHistory
import           Matterhorn.Login
import           Matterhorn.State.Flagging
import           Matterhorn.State.Teams ( buildTeamState )
import           Matterhorn.State.Setup.Threads
import           Matterhorn.Themes
import           Matterhorn.TimeUtils ( lookupLocalTimeZone, utcTimezone )
import           Matterhorn.Types
import           Matterhorn.Emoji
import           Matterhorn.FilePaths ( userEmojiJsonPath, bundledEmojiJsonPath )


incompleteCredentials :: Config -> ConnectionInfo
incompleteCredentials :: Config -> ConnectionInfo
incompleteCredentials Config
config =
    ConnectionInfo :: Text
-> Int
-> Text
-> Text
-> Maybe Text
-> Text
-> Text
-> ConnectionType
-> ConnectionInfo
ConnectionInfo { _ciHostname :: Text
_ciHostname = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Config -> Maybe Text
configHost Config
config)
                   , _ciPort :: Int
_ciPort     = Config -> Int
configPort Config
config
                   , _ciUrlPath :: Text
_ciUrlPath  = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Config -> Maybe Text
configUrlPath Config
config)
                   , _ciUsername :: Text
_ciUsername = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Config -> Maybe Text
configUser Config
config)
                   , _ciPassword :: Text
_ciPassword = case Config -> Maybe PasswordSource
configPass Config
config of
                                       Just (PasswordString Text
s) -> Text
s
                                       Maybe PasswordSource
_                       -> Text
""
                   , _ciOTPToken :: Maybe Text
_ciOTPToken = Maybe Text
forall a. Maybe a
Nothing
                   , _ciAccessToken :: Text
_ciAccessToken = case Config -> Maybe TokenSource
configToken Config
config of
                                          Just (TokenString Text
s) -> Text
s
                                          Maybe TokenSource
_                    -> Text
""
                   , _ciType :: ConnectionType
_ciType     = Config -> ConnectionType
configConnectionType Config
config
                   }

apiLogEventToLogMessage :: LogEvent -> IO LogMessage
apiLogEventToLogMessage :: LogEvent -> IO LogMessage
apiLogEventToLogMessage LogEvent
ev = do
    UTCTime
now <- IO UTCTime
getCurrentTime
    let msg :: Text
msg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Function: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> LogEvent -> String
logFunction LogEvent
ev String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                       String
", event: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> LogEventType -> String
forall a. Show a => a -> String
show (LogEvent -> LogEventType
logEventType LogEvent
ev)
    LogMessage -> IO LogMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (LogMessage -> IO LogMessage) -> LogMessage -> IO LogMessage
forall a b. (a -> b) -> a -> b
$ LogMessage :: Text -> Maybe LogContext -> LogCategory -> UTCTime -> LogMessage
LogMessage { logMessageCategory :: LogCategory
logMessageCategory = LogCategory
LogAPI
                        , logMessageText :: Text
logMessageText = Text
msg
                        , logMessageContext :: Maybe LogContext
logMessageContext = Maybe LogContext
forall a. Maybe a
Nothing
                        , logMessageTimestamp :: UTCTime
logMessageTimestamp = UTCTime
now
                        }

setupState :: IO Vty.Vty -> Maybe FilePath -> Config -> IO (ChatState, Vty.Vty)
setupState :: IO Vty -> Maybe String -> Config -> IO (ChatState, Vty)
setupState IO Vty
mkVty Maybe String
mLogLocation Config
config = do
    Vty
initialVty <- IO Vty
mkVty

    BChan MHEvent
eventChan <- Int -> IO (BChan MHEvent)
forall a. Int -> IO (BChan a)
newBChan Int
2500
    LogManager
logMgr <- BChan MHEvent -> Int -> IO LogManager
newLogManager BChan MHEvent
eventChan (Config -> Int
configLogMaxBufferSize Config
config)

    -- If we got an initial log location, start logging there.
    case Maybe String
mLogLocation of
        Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just String
loc -> LogManager -> String -> IO ()
startLoggingToFile LogManager
logMgr String
loc

    let logApiEvent :: LogEvent -> IO ()
logApiEvent LogEvent
ev = LogEvent -> IO LogMessage
apiLogEventToLogMessage LogEvent
ev IO LogMessage -> (LogMessage -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogManager -> LogMessage -> IO ()
sendLogMessage LogManager
logMgr
        setLogger :: ConnectionData -> ConnectionData
setLogger ConnectionData
cd = ConnectionData
cd ConnectionData -> (LogEvent -> IO ()) -> ConnectionData
`withLogger` LogEvent -> IO ()
logApiEvent

    (Maybe LoginSuccess
mLoginSuccess, Vty
loginVty) <- Vty
-> IO Vty
-> (ConnectionData -> ConnectionData)
-> LogManager
-> ConnectionInfo
-> IO (Maybe LoginSuccess, Vty)
interactiveGetLoginSession Vty
initialVty IO Vty
mkVty
                                                            ConnectionData -> ConnectionData
setLogger
                                                            LogManager
logMgr
                                                            (Config -> ConnectionInfo
incompleteCredentials Config
config)

    let shutdown :: Vty -> IO b
shutdown Vty
vty = do
            Vty -> IO ()
Vty.shutdown Vty
vty
            IO b
forall a. IO a
exitSuccess

    (Session
session, User
me, ConnectionData
cd, Maybe Text
mbTeam) <- case Maybe LoginSuccess
mLoginSuccess of
        Maybe LoginSuccess
Nothing ->
            -- The user never attempted a connection and just chose to
            -- quit.
            Vty -> IO (Session, User, ConnectionData, Maybe Text)
forall b. Vty -> IO b
shutdown Vty
loginVty
        Just (LoginSuccess ConnectionData
cd Session
sess User
user Maybe Text
mbTeam) ->
            -- The user attempted a connection and succeeded so continue
            -- with setup.
            (Session, User, ConnectionData, Maybe Text)
-> IO (Session, User, ConnectionData, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Session
sess, User
user, ConnectionData
cd, Maybe Text
mbTeam)

    [Team]
teams <- Seq Team -> [Team]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq Team -> [Team]) -> IO (Seq Team) -> IO [Team]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserParam -> Session -> IO (Seq Team)
mmGetUsersTeams UserParam
UserMe Session
session
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Team] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Team]
teams) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn String
"Error: your account is not a member of any teams"
        IO ()
forall a. IO a
exitFailure

    let initialTeamId :: TeamId
initialTeamId = TeamId -> Maybe TeamId -> TeamId
forall a. a -> Maybe a -> a
fromMaybe (Team -> TeamId
teamId (Team -> TeamId) -> Team -> TeamId
forall a b. (a -> b) -> a -> b
$ [Team] -> Team
forall a. [a] -> a
head ([Team] -> Team) -> [Team] -> Team
forall a b. (a -> b) -> a -> b
$ [Team] -> [Team]
sortTeams [Team]
teams) (Maybe TeamId -> TeamId) -> Maybe TeamId -> TeamId
forall a b. (a -> b) -> a -> b
$ do
            Text
tName <- Maybe Text
mbTeam Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Text
configTeam Config
config
            let matchingTeam :: Maybe Team
matchingTeam = [Team] -> Maybe Team
forall a. [a] -> Maybe a
listToMaybe ([Team] -> Maybe Team) -> [Team] -> Maybe Team
forall a b. (a -> b) -> a -> b
$ (Team -> Bool) -> [Team] -> [Team]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Team -> Bool
matchesTeam Text
tName) [Team]
teams
            Team -> TeamId
teamId (Team -> TeamId) -> Maybe Team -> Maybe TeamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Team
matchingTeam

    TChan [UserId]
userStatusChan <- IO (TChan [UserId])
forall a. IO (TChan a)
STM.newTChanIO
    TChan ProgramOutput
slc <- IO (TChan ProgramOutput)
forall a. IO (TChan a)
STM.newTChanIO
    TChan WebsocketAction
wac <- IO (TChan WebsocketAction)
forall a. IO (TChan a)
STM.newTChanIO

    Seq Preference
prefs <- UserParam -> Session -> IO (Seq Preference)
mmGetUsersPreferences UserParam
UserMe Session
session
    let userPrefs :: UserPreferences
userPrefs = Seq Preference -> UserPreferences -> UserPreferences
setUserPreferences Seq Preference
prefs UserPreferences
defaultUserPreferences
        themeName :: Text
themeName = case Config -> Maybe Text
configTheme Config
config of
            Maybe Text
Nothing -> InternalTheme -> Text
internalThemeName InternalTheme
defaultTheme
            Just Text
t -> Text
t
        baseTheme :: Theme
baseTheme = InternalTheme -> Theme
internalTheme (InternalTheme -> Theme) -> InternalTheme -> Theme
forall a b. (a -> b) -> a -> b
$ InternalTheme -> Maybe InternalTheme -> InternalTheme
forall a. a -> Maybe a -> a
fromMaybe InternalTheme
defaultTheme (Text -> Maybe InternalTheme
lookupTheme Text
themeName)

    -- Did the configuration specify a theme customization file? If so,
    -- load it and customize the theme.
    Theme
custTheme <- case Config -> Maybe Text
configThemeCustomizationFile Config
config of
        Maybe Text
Nothing -> Theme -> IO Theme
forall (m :: * -> *) a. Monad m => a -> m a
return Theme
baseTheme
        Just Text
path ->
            -- If we have no configuration path (i.e. we used the default
            -- config) then ignore theme customization.
            let pathStr :: String
pathStr = Text -> String
T.unpack Text
path
            in if String -> Bool
isRelative String
pathStr Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Config -> Maybe String
configAbsPath Config
config)
               then Theme -> IO Theme
forall (m :: * -> *) a. Monad m => a -> m a
return Theme
baseTheme
               else do
                   let absPath :: String
absPath = if String -> Bool
isRelative String
pathStr
                                 then (String -> String
dropFileName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Config -> Maybe String
configAbsPath Config
config) String -> String -> String
</> String
pathStr
                                 else String
pathStr
                   Either String Theme
result <- String -> Theme -> IO (Either String Theme)
loadCustomizations String
absPath Theme
baseTheme
                   case Either String Theme
result of
                       Left String
e -> do
                           Vty -> IO ()
Vty.shutdown Vty
loginVty
                           String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error loading theme customization from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
absPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e
                           IO Theme
forall a. IO a
exitFailure
                       Right Theme
t -> Theme -> IO Theme
forall (m :: * -> *) a. Monad m => a -> m a
return Theme
t

    TChan (IO (Maybe (MH ())))
requestChan <- STM (TChan (IO (Maybe (MH ())))) -> IO (TChan (IO (Maybe (MH ()))))
forall a. STM a -> IO a
STM.atomically STM (TChan (IO (Maybe (MH ()))))
forall a. STM (TChan a)
STM.newTChan

    EmojiCollection
emoji <- (String -> EmojiCollection)
-> (EmojiCollection -> EmojiCollection)
-> Either String EmojiCollection
-> EmojiCollection
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (EmojiCollection -> String -> EmojiCollection
forall a b. a -> b -> a
const EmojiCollection
emptyEmojiCollection) EmojiCollection -> EmojiCollection
forall a. a -> a
id (Either String EmojiCollection -> EmojiCollection)
-> IO (Either String EmojiCollection) -> IO EmojiCollection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Either String EmojiCollection
result1 <- String -> IO (Either String EmojiCollection)
loadEmoji (String -> IO (Either String EmojiCollection))
-> IO String -> IO (Either String EmojiCollection)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
userEmojiJsonPath
        case Either String EmojiCollection
result1 of
            Right EmojiCollection
e -> Either String EmojiCollection -> IO (Either String EmojiCollection)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String EmojiCollection
 -> IO (Either String EmojiCollection))
-> Either String EmojiCollection
-> IO (Either String EmojiCollection)
forall a b. (a -> b) -> a -> b
$ EmojiCollection -> Either String EmojiCollection
forall a b. b -> Either a b
Right EmojiCollection
e
            Left String
_ -> String -> IO (Either String EmojiCollection)
loadEmoji (String -> IO (Either String EmojiCollection))
-> IO String -> IO (Either String EmojiCollection)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
bundledEmojiJsonPath

    Maybe Aspell
spResult <- Config -> IO (Maybe Aspell)
maybeStartSpellChecker Config
config

    let cr :: ChatResources
cr = ChatResources :: Session
-> Maybe ThreadId
-> ConnectionData
-> TChan (IO (Maybe (MH ())))
-> BChan MHEvent
-> TChan ProgramOutput
-> TChan WebsocketAction
-> AttrMap
-> TChan [UserId]
-> Config
-> Set PostId
-> UserPreferences
-> SyntaxMap
-> LogManager
-> EmojiCollection
-> Maybe Aspell
-> ChatResources
ChatResources { _crSession :: Session
_crSession             = Session
session
                           , _crWebsocketThreadId :: Maybe ThreadId
_crWebsocketThreadId   = Maybe ThreadId
forall a. Maybe a
Nothing
                           , _crConn :: ConnectionData
_crConn                = ConnectionData
cd
                           , _crRequestQueue :: TChan (IO (Maybe (MH ())))
_crRequestQueue        = TChan (IO (Maybe (MH ())))
requestChan
                           , _crEventQueue :: BChan MHEvent
_crEventQueue          = BChan MHEvent
eventChan
                           , _crSubprocessLog :: TChan ProgramOutput
_crSubprocessLog       = TChan ProgramOutput
slc
                           , _crWebsocketActionChan :: TChan WebsocketAction
_crWebsocketActionChan = TChan WebsocketAction
wac
                           , _crTheme :: AttrMap
_crTheme               = Theme -> AttrMap
themeToAttrMap Theme
custTheme
                           , _crStatusUpdateChan :: TChan [UserId]
_crStatusUpdateChan    = TChan [UserId]
userStatusChan
                           , _crConfiguration :: Config
_crConfiguration       = Config
config
                           , _crFlaggedPosts :: Set PostId
_crFlaggedPosts        = Set PostId
forall a. Monoid a => a
mempty
                           , _crUserPreferences :: UserPreferences
_crUserPreferences     = UserPreferences
userPrefs
                           , _crSyntaxMap :: SyntaxMap
_crSyntaxMap           = SyntaxMap
forall a. Monoid a => a
mempty
                           , _crLogManager :: LogManager
_crLogManager          = LogManager
logMgr
                           , _crEmoji :: EmojiCollection
_crEmoji               = EmojiCollection
emoji
                           , _crSpellChecker :: Maybe Aspell
_crSpellChecker        = Maybe Aspell
spResult
                           }

    ChatState
st <- ChatResources -> TeamId -> [Team] -> User -> IO ChatState
initializeState ChatResources
cr TeamId
initialTeamId [Team]
teams User
me

    (ChatState, Vty) -> IO (ChatState, Vty)
forall (m :: * -> *) a. Monad m => a -> m a
return (ChatState
st, Vty
loginVty)

initializeState :: ChatResources -> TeamId -> [Team] -> User -> IO ChatState
initializeState :: ChatResources -> TeamId -> [Team] -> User -> IO ChatState
initializeState ChatResources
cr TeamId
initialTeamId [Team]
teams User
me = do
    let session :: Session
session = ChatResources -> Session
getResourceSession ChatResources
cr
        requestChan :: TChan (IO (Maybe (MH ())))
requestChan = ChatResources
crChatResources
-> Getting
     (TChan (IO (Maybe (MH ()))))
     ChatResources
     (TChan (IO (Maybe (MH ()))))
-> TChan (IO (Maybe (MH ())))
forall s a. s -> Getting a s a -> a
^.Getting
  (TChan (IO (Maybe (MH ()))))
  ChatResources
  (TChan (IO (Maybe (MH ()))))
Lens' ChatResources (TChan (IO (Maybe (MH ()))))
crRequestQueue

    TimeZoneSeries
tz <- TimeZoneSeries
-> Either SomeException TimeZoneSeries -> TimeZoneSeries
forall b a. b -> Either a b -> b
fromRight TimeZoneSeries
utcTimezone (Either SomeException TimeZoneSeries -> TimeZoneSeries)
-> IO (Either SomeException TimeZoneSeries) -> IO TimeZoneSeries
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either SomeException TimeZoneSeries)
lookupLocalTimeZone

    InputHistory
hist <- do
        Either String InputHistory
result <- IO (Either String InputHistory)
readHistory
        case Either String InputHistory
result of
            Left String
_ -> InputHistory -> IO InputHistory
forall (m :: * -> *) a. Monad m => a -> m a
return InputHistory
newHistory
            Right InputHistory
h -> InputHistory -> IO InputHistory
forall (m :: * -> *) a. Monad m => a -> m a
return InputHistory
h

    --------------------------------------------------------------------
    -- Start background worker threads:
    --
    --  * Syntax definition loader
    Config -> BChan MHEvent -> IO ()
startSyntaxMapLoaderThread (ChatResources
crChatResources -> Getting Config ChatResources Config -> Config
forall s a. s -> Getting a s a -> a
^.Getting Config ChatResources Config
Lens' ChatResources Config
crConfiguration) (ChatResources
crChatResources
-> Getting (BChan MHEvent) ChatResources (BChan MHEvent)
-> BChan MHEvent
forall s a. s -> Getting a s a -> a
^.Getting (BChan MHEvent) ChatResources (BChan MHEvent)
Lens' ChatResources (BChan MHEvent)
crEventQueue)

    --  * Main async queue worker thread
    Config -> TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO ()
startAsyncWorkerThread (ChatResources
crChatResources -> Getting Config ChatResources Config -> Config
forall s a. s -> Getting a s a -> a
^.Getting Config ChatResources Config
Lens' ChatResources Config
crConfiguration) (ChatResources
crChatResources
-> Getting
     (TChan (IO (Maybe (MH ()))))
     ChatResources
     (TChan (IO (Maybe (MH ()))))
-> TChan (IO (Maybe (MH ())))
forall s a. s -> Getting a s a -> a
^.Getting
  (TChan (IO (Maybe (MH ()))))
  ChatResources
  (TChan (IO (Maybe (MH ()))))
Lens' ChatResources (TChan (IO (Maybe (MH ()))))
crRequestQueue) (ChatResources
crChatResources
-> Getting (BChan MHEvent) ChatResources (BChan MHEvent)
-> BChan MHEvent
forall s a. s -> Getting a s a -> a
^.Getting (BChan MHEvent) ChatResources (BChan MHEvent)
Lens' ChatResources (BChan MHEvent)
crEventQueue)

    --  * User status thread
    TChan [UserId] -> Session -> TChan (IO (Maybe (MH ()))) -> IO ()
startUserStatusUpdateThread (ChatResources
crChatResources
-> Getting (TChan [UserId]) ChatResources (TChan [UserId])
-> TChan [UserId]
forall s a. s -> Getting a s a -> a
^.Getting (TChan [UserId]) ChatResources (TChan [UserId])
Lens' ChatResources (TChan [UserId])
crStatusUpdateChan) Session
session TChan (IO (Maybe (MH ())))
requestChan

    --  * Refresher for users who are typing currently
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configShowTypingIndicator (ChatResources
crChatResources -> Getting Config ChatResources Config -> Config
forall s a. s -> Getting a s a -> a
^.Getting Config ChatResources Config
Lens' ChatResources Config
crConfiguration)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      TChan (IO (Maybe (MH ()))) -> IO ()
startTypingUsersRefreshThread TChan (IO (Maybe (MH ())))
requestChan

    --  * Timezone change monitor
    TimeZoneSeries -> TChan (IO (Maybe (MH ()))) -> IO ()
startTimezoneMonitorThread TimeZoneSeries
tz TChan (IO (Maybe (MH ())))
requestChan

    --  * Subprocess logger
    TChan ProgramOutput -> TChan (IO (Maybe (MH ()))) -> IO ()
startSubprocessLoggerThread (ChatResources
crChatResources
-> Getting
     (TChan ProgramOutput) ChatResources (TChan ProgramOutput)
-> TChan ProgramOutput
forall s a. s -> Getting a s a -> a
^.Getting (TChan ProgramOutput) ChatResources (TChan ProgramOutput)
Lens' ChatResources (TChan ProgramOutput)
crSubprocessLog) TChan (IO (Maybe (MH ())))
requestChan

    -- End thread startup ----------------------------------------------

    -- For each team, build a team state and load that team's last-run
    -- state, if any.
    ([TeamState]
teamStates, [ClientChannels]
chanLists) <- [(TeamState, ClientChannels)] -> ([TeamState], [ClientChannels])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(TeamState, ClientChannels)] -> ([TeamState], [ClientChannels]))
-> IO [(TeamState, ClientChannels)]
-> IO ([TeamState], [ClientChannels])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Team -> IO (TeamState, ClientChannels))
-> [Team] -> IO [(TeamState, ClientChannels)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ChatResources -> User -> Team -> IO (TeamState, ClientChannels)
buildTeamState ChatResources
cr User
me) [Team]
teams

    let startupState :: StartupStateInfo
startupState =
            StartupStateInfo :: ChatResources
-> User
-> HashMap TeamId TeamState
-> TimeZoneSeries
-> InputHistory
-> TeamId
-> StartupStateInfo
StartupStateInfo { startupStateResources :: ChatResources
startupStateResources      = ChatResources
cr
                             , startupStateConnectedUser :: User
startupStateConnectedUser  = User
me
                             , startupStateTimeZone :: TimeZoneSeries
startupStateTimeZone       = TimeZoneSeries
tz
                             , startupStateInitialHistory :: InputHistory
startupStateInitialHistory = InputHistory
hist
                             , startupStateInitialTeam :: TeamId
startupStateInitialTeam    = TeamId
initialTeamId
                             , startupStateTeams :: HashMap TeamId TeamState
startupStateTeams          = HashMap TeamId TeamState
teamMap
                             }
        clientChans :: ClientChannels
clientChans = [ClientChannels] -> ClientChannels
forall a. Monoid a => [a] -> a
mconcat [ClientChannels]
chanLists
        st :: ChatState
st = StartupStateInfo -> ChatState
newState StartupStateInfo
startupState ChatState -> (ChatState -> ChatState) -> ChatState
forall a b. a -> (a -> b) -> b
& (ClientChannels -> Identity ClientChannels)
-> ChatState -> Identity ChatState
Lens' ChatState ClientChannels
csChannels ((ClientChannels -> Identity ClientChannels)
 -> ChatState -> Identity ChatState)
-> ClientChannels -> ChatState -> ChatState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ClientChannels
clientChans
        teamMap :: HashMap TeamId TeamState
teamMap = [(TeamId, TeamState)] -> HashMap TeamId TeamState
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(TeamId, TeamState)] -> HashMap TeamId TeamState)
-> [(TeamId, TeamState)] -> HashMap TeamId TeamState
forall a b. (a -> b) -> a -> b
$ (\TeamState
ts -> (Team -> TeamId
teamId (Team -> TeamId) -> Team -> TeamId
forall a b. (a -> b) -> a -> b
$ TeamState -> Team
_tsTeam TeamState
ts, TeamState
ts)) (TeamState -> (TeamId, TeamState))
-> [TeamState] -> [(TeamId, TeamState)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TeamState] -> [TeamState]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList [TeamState]
teamStates

    Seq FlaggedPost -> ChatState -> IO ()
loadFlaggedMessages (ChatResources
crChatResources
-> Getting (Seq FlaggedPost) ChatResources (Seq FlaggedPost)
-> Seq FlaggedPost
forall s a. s -> Getting a s a -> a
^.(UserPreferences -> Const (Seq FlaggedPost) UserPreferences)
-> ChatResources -> Const (Seq FlaggedPost) ChatResources
Lens' ChatResources UserPreferences
crUserPreferences((UserPreferences -> Const (Seq FlaggedPost) UserPreferences)
 -> ChatResources -> Const (Seq FlaggedPost) ChatResources)
-> ((Seq FlaggedPost -> Const (Seq FlaggedPost) (Seq FlaggedPost))
    -> UserPreferences -> Const (Seq FlaggedPost) UserPreferences)
-> Getting (Seq FlaggedPost) ChatResources (Seq FlaggedPost)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Seq FlaggedPost -> Const (Seq FlaggedPost) (Seq FlaggedPost))
-> UserPreferences -> Const (Seq FlaggedPost) UserPreferences
Lens' UserPreferences (Seq FlaggedPost)
userPrefFlaggedPostList) ChatState
st

    -- Trigger an initial websocket refresh
    BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan (ChatResources
crChatResources
-> Getting (BChan MHEvent) ChatResources (BChan MHEvent)
-> BChan MHEvent
forall s a. s -> Getting a s a -> a
^.Getting (BChan MHEvent) ChatResources (BChan MHEvent)
Lens' ChatResources (BChan MHEvent)
crEventQueue) MHEvent
RefreshWebsocketEvent

    ChatState -> IO ChatState
forall (m :: * -> *) a. Monad m => a -> m a
return ChatState
st