{-# 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 { _ciHostname :: Text
_ciHostname = 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 = forall a. a -> Maybe a -> a
fromMaybe Text
"" (Config -> Maybe Text
configUrlPath Config
config)
, _ciUsername :: Text
_ciUsername = 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 = case Config -> Maybe OTPTokenSource
configOTPToken Config
config of
Just (OTPTokenString Text
s) -> forall a. a -> Maybe a
Just Text
s
Maybe OTPTokenSource
_ -> forall a. a -> Maybe a
Just Text
""
, _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 forall a b. (a -> b) -> a -> b
$ String
"Function: " forall a. Semigroup a => a -> a -> a
<> LogEvent -> String
logFunction LogEvent
ev forall a. Semigroup a => a -> a -> a
<>
String
", event: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (LogEvent -> LogEventType
logEventType LogEvent
ev)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LogMessage { logMessageCategory :: LogCategory
logMessageCategory = LogCategory
LogAPI
, logMessageText :: Text
logMessageText = Text
msg
, logMessageContext :: Maybe LogContext
logMessageContext = 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 <- 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)
case Maybe String
mLogLocation of
Maybe String
Nothing -> 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 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
forall a. IO a
exitSuccess
(Session
session, User
me, ConnectionData
cd, Maybe Text
mbTeam) <- case Maybe LoginSuccess
mLoginSuccess of
Maybe LoginSuccess
Nothing ->
forall {b}. Vty -> IO b
shutdown Vty
loginVty
Just (LoginSuccess ConnectionData
cd Session
sess User
user Maybe Text
mbTeam) ->
forall (m :: * -> *) a. Monad m => a -> m a
return (Session
sess, User
user, ConnectionData
cd, Maybe Text
mbTeam)
[Team]
teams <- forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserParam -> Session -> IO (Seq Team)
mmGetUsersTeams UserParam
UserMe Session
session
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Team]
teams) forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn String
"Error: your account is not a member of any teams"
forall a. IO a
exitFailure
let initialTeamId :: TeamId
initialTeamId = forall a. a -> Maybe a -> a
fromMaybe (Team -> TeamId
teamId forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Team]
teams) forall a b. (a -> b) -> a -> b
$ do
Text
tName <- Maybe Text
mbTeam forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Text
configTeam Config
config
let matchingTeam :: Maybe Team
matchingTeam = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Team -> Bool
matchesTeam Text
tName) [Team]
teams
Team -> TeamId
teamId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Team
matchingTeam
TChan [UserId]
userStatusChan <- forall a. IO (TChan a)
STM.newTChanIO
TChan ProgramOutput
slc <- forall a. IO (TChan a)
STM.newTChanIO
TChan WebsocketAction
wac <- 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 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe InternalTheme
defaultTheme (Text -> Maybe InternalTheme
lookupTheme Text
themeName)
Theme
custTheme <- case Config -> Maybe Text
configThemeCustomizationFile Config
config of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Theme
baseTheme
Just Text
path ->
let pathStr :: String
pathStr = Text -> String
T.unpack Text
path
in if String -> Bool
isRelative String
pathStr Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (Config -> Maybe String
configAbsPath Config
config)
then 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 forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust 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 forall a b. (a -> b) -> a -> b
$ String
"Error loading theme customization from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
absPath forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
e
forall a. IO a
exitFailure
Right Theme
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Theme
t
RequestChan
requestChan <- forall a. STM a -> IO a
STM.atomically forall a. STM (TChan a)
STM.newTChan
EmojiCollection
emoji <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const EmojiCollection
emptyEmojiCollection) forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Either String EmojiCollection
result1 <- String -> IO (Either String EmojiCollection)
loadEmoji 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right EmojiCollection
e
Left String
_ -> String -> IO (Either String EmojiCollection)
loadEmoji 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 { _crSession :: Session
_crSession = Session
session
, _crWebsocketThreadId :: Maybe ThreadId
_crWebsocketThreadId = forall a. Maybe a
Nothing
, _crConn :: ConnectionData
_crConn = ConnectionData
cd
, _crRequestQueue :: RequestChan
_crRequestQueue = RequestChan
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 = forall a. Monoid a => a
mempty
, _crUserPreferences :: UserPreferences
_crUserPreferences = UserPreferences
userPrefs
, _crSyntaxMap :: SyntaxMap
_crSyntaxMap = 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
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 :: RequestChan
requestChan = ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources RequestChan
crRequestQueue
TimeZoneSeries
tz <- forall b a. b -> Either a b -> b
fromRight TimeZoneSeries
utcTimezone 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return InputHistory
newHistory
Right InputHistory
h -> forall (m :: * -> *) a. Monad m => a -> m a
return InputHistory
h
Config -> BChan MHEvent -> IO ()
startSyntaxMapLoaderThread (ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources Config
crConfiguration) (ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources (BChan MHEvent)
crEventQueue)
Config -> RequestChan -> BChan MHEvent -> IO ()
startAsyncWorkerThread (ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources Config
crConfiguration) (ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources RequestChan
crRequestQueue) (ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources (BChan MHEvent)
crEventQueue)
TChan [UserId] -> Session -> RequestChan -> IO ()
startUserStatusUpdateThread (ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources (TChan [UserId])
crStatusUpdateChan) Session
session RequestChan
requestChan
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configShowTypingIndicator (ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources Config
crConfiguration)) forall a b. (a -> b) -> a -> b
$
RequestChan -> IO ()
startTypingUsersRefreshThread RequestChan
requestChan
TimeZoneSeries -> RequestChan -> IO ()
startTimezoneMonitorThread TimeZoneSeries
tz RequestChan
requestChan
TChan ProgramOutput -> RequestChan -> IO ()
startSubprocessLoggerThread (ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources (TChan ProgramOutput)
crSubprocessLog) RequestChan
requestChan
([TeamState]
teamStates, [ClientChannels]
chanLists) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 { 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 = forall a. Monoid a => [a] -> a
mconcat [ClientChannels]
chanLists
st :: ChatState
st = StartupStateInfo -> ChatState
newState StartupStateInfo
startupState forall a b. a -> (a -> b) -> b
& Lens' ChatState ClientChannels
csChannels forall s t a b. ASetter s t a b -> b -> s -> t
.~ ClientChannels
clientChans
teamMap :: HashMap TeamId TeamState
teamMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall a b. (a -> b) -> a -> b
$ (\TeamState
ts -> (Team -> TeamId
teamId forall a b. (a -> b) -> a -> b
$ TeamState -> Team
_tsTeam TeamState
ts, TeamState
ts)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList [TeamState]
teamStates
Seq FlaggedPost -> ChatState -> IO ()
loadFlaggedMessages (ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources UserPreferences
crUserPreferencesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' UserPreferences (Seq FlaggedPost)
userPrefFlaggedPostList) ChatState
st
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan (ChatResources
crforall s a. s -> Getting a s a -> a
^.Lens' ChatResources (BChan MHEvent)
crEventQueue) MHEvent
RefreshWebsocketEvent
forall (m :: * -> *) a. Monad m => a -> m a
return ChatState
st