1{-# LANGUAGE TypeFamilies #-} 2module Matterhorn.State.Setup 3 ( setupState 4 ) 5where 6 7import Prelude () 8import Matterhorn.Prelude 9 10import Brick.BChan ( newBChan ) 11import Brick.Themes ( themeToAttrMap, loadCustomizations ) 12import qualified Control.Concurrent.STM as STM 13import Data.Either ( fromRight ) 14import qualified Data.Foldable as F 15import qualified Data.HashMap.Strict as HM 16import Data.Maybe ( fromJust ) 17import qualified Data.Text as T 18import Data.Time.Clock ( getCurrentTime ) 19import qualified Graphics.Vty as Vty 20import Lens.Micro.Platform ( (.~) ) 21import System.Exit ( exitFailure, exitSuccess ) 22import System.FilePath ( (</>), isRelative, dropFileName ) 23 24import Network.Mattermost.Endpoints 25import Network.Mattermost.Types 26 27import Matterhorn.Config 28import Matterhorn.InputHistory 29import Matterhorn.Login 30import Matterhorn.State.Flagging 31import Matterhorn.State.Teams ( buildTeamState ) 32import Matterhorn.State.Setup.Threads 33import Matterhorn.Themes 34import Matterhorn.TimeUtils ( lookupLocalTimeZone, utcTimezone ) 35import Matterhorn.Types 36import Matterhorn.Types.Common 37import Matterhorn.Emoji 38import Matterhorn.FilePaths ( userEmojiJsonPath, bundledEmojiJsonPath ) 39 40 41incompleteCredentials :: Config -> ConnectionInfo 42incompleteCredentials config = ConnectionInfo 43 { _ciHostname = fromMaybe "" (configHost config) 44 , _ciPort = configPort config 45 , _ciUrlPath = fromMaybe "" (configUrlPath config) 46 , _ciUsername = fromMaybe "" (configUser config) 47 , _ciPassword = case configPass config of 48 Just (PasswordString s) -> s 49 _ -> "" 50 , _ciAccessToken = case configToken config of 51 Just (TokenString s) -> s 52 _ -> "" 53 , _ciType = configConnectionType config 54 } 55 56apiLogEventToLogMessage :: LogEvent -> IO LogMessage 57apiLogEventToLogMessage ev = do 58 now <- getCurrentTime 59 let msg = T.pack $ "Function: " <> logFunction ev <> 60 ", event: " <> show (logEventType ev) 61 return $ LogMessage { logMessageCategory = LogAPI 62 , logMessageText = msg 63 , logMessageContext = Nothing 64 , logMessageTimestamp = now 65 } 66 67setupState :: IO Vty.Vty -> Maybe FilePath -> Config -> IO (ChatState, Vty.Vty) 68setupState mkVty mLogLocation config = do 69 initialVty <- mkVty 70 71 eventChan <- newBChan 2500 72 logMgr <- newLogManager eventChan (configLogMaxBufferSize config) 73 74 -- If we got an initial log location, start logging there. 75 case mLogLocation of 76 Nothing -> return () 77 Just loc -> startLoggingToFile logMgr loc 78 79 let logApiEvent ev = apiLogEventToLogMessage ev >>= sendLogMessage logMgr 80 setLogger cd = cd `withLogger` logApiEvent 81 82 (mLastAttempt, loginVty) <- interactiveGetLoginSession initialVty mkVty 83 setLogger 84 logMgr 85 (incompleteCredentials config) 86 87 let shutdown vty = do 88 Vty.shutdown vty 89 exitSuccess 90 91 (session, me, cd, mbTeam) <- case mLastAttempt of 92 Nothing -> 93 -- The user never attempted a connection and just chose to 94 -- quit. 95 shutdown loginVty 96 Just (AttemptFailed {}) -> 97 -- The user attempted a connection and failed, and then chose 98 -- to quit. 99 shutdown loginVty 100 Just (AttemptSucceeded _ cd sess user mbTeam) -> 101 -- The user attempted a connection and succeeded so continue 102 -- with setup. 103 return (sess, user, cd, mbTeam) 104 105 teams <- F.toList <$> mmGetUsersTeams UserMe session 106 when (null teams) $ do 107 putStrLn "Error: your account is not a member of any teams" 108 exitFailure 109 110 let initialTeamId = fromMaybe (teamId $ head $ sortTeams teams) $ do 111 tName <- mbTeam <|> configTeam config 112 let matchingTeam = listToMaybe $ filter (matchesTeam tName) teams 113 teamId <$> matchingTeam 114 115 userStatusChan <- STM.newTChanIO 116 slc <- STM.newTChanIO 117 wac <- STM.newTChanIO 118 119 prefs <- mmGetUsersPreferences UserMe session 120 let userPrefs = setUserPreferences prefs defaultUserPreferences 121 themeName = case configTheme config of 122 Nothing -> internalThemeName defaultTheme 123 Just t -> t 124 baseTheme = internalTheme $ fromMaybe defaultTheme (lookupTheme themeName) 125 126 -- Did the configuration specify a theme customization file? If so, 127 -- load it and customize the theme. 128 custTheme <- case configThemeCustomizationFile config of 129 Nothing -> return baseTheme 130 Just path -> 131 -- If we have no configuration path (i.e. we used the default 132 -- config) then ignore theme customization. 133 let pathStr = T.unpack path 134 in if isRelative pathStr && isNothing (configAbsPath config) 135 then return baseTheme 136 else do 137 let absPath = if isRelative pathStr 138 then (dropFileName $ fromJust $ configAbsPath config) </> pathStr 139 else pathStr 140 result <- loadCustomizations absPath baseTheme 141 case result of 142 Left e -> do 143 Vty.shutdown loginVty 144 putStrLn $ "Error loading theme customization from " <> show absPath <> ": " <> e 145 exitFailure 146 Right t -> return t 147 148 requestChan <- STM.atomically STM.newTChan 149 150 emoji <- either (const emptyEmojiCollection) id <$> do 151 result1 <- loadEmoji =<< userEmojiJsonPath 152 case result1 of 153 Right e -> return $ Right e 154 Left _ -> loadEmoji =<< bundledEmojiJsonPath 155 156 let cr = ChatResources { _crSession = session 157 , _crWebsocketThreadId = Nothing 158 , _crConn = cd 159 , _crRequestQueue = requestChan 160 , _crEventQueue = eventChan 161 , _crSubprocessLog = slc 162 , _crWebsocketActionChan = wac 163 , _crTheme = themeToAttrMap custTheme 164 , _crStatusUpdateChan = userStatusChan 165 , _crConfiguration = config 166 , _crFlaggedPosts = mempty 167 , _crUserPreferences = userPrefs 168 , _crSyntaxMap = mempty 169 , _crLogManager = logMgr 170 , _crEmoji = emoji 171 } 172 173 st <- initializeState cr initialTeamId teams me 174 175 return (st, loginVty) 176 177matchesTeam :: T.Text -> Team -> Bool 178matchesTeam tName t = 179 let normalizeUserText = normalize . sanitizeUserText 180 normalize = T.strip . T.toLower 181 urlName = normalizeUserText $ teamName t 182 displayName = normalizeUserText $ teamDisplayName t 183 in normalize tName `elem` [displayName, urlName] 184 185initializeState :: ChatResources -> TeamId -> [Team] -> User -> IO ChatState 186initializeState cr initialTeamId teams me = do 187 let session = getResourceSession cr 188 requestChan = cr^.crRequestQueue 189 190 tz <- fromRight utcTimezone <$> lookupLocalTimeZone 191 192 hist <- do 193 result <- readHistory 194 case result of 195 Left _ -> return newHistory 196 Right h -> return h 197 198 -------------------------------------------------------------------- 199 -- Start background worker threads: 200 -- 201 -- * Syntax definition loader 202 startSyntaxMapLoaderThread (cr^.crConfiguration) (cr^.crEventQueue) 203 204 -- * Main async queue worker thread 205 startAsyncWorkerThread (cr^.crConfiguration) (cr^.crRequestQueue) (cr^.crEventQueue) 206 207 -- * User status thread 208 startUserStatusUpdateThread (cr^.crStatusUpdateChan) session requestChan 209 210 -- * Refresher for users who are typing currently 211 when (configShowTypingIndicator (cr^.crConfiguration)) $ 212 startTypingUsersRefreshThread requestChan 213 214 -- * Timezone change monitor 215 startTimezoneMonitorThread tz requestChan 216 217 -- * Subprocess logger 218 startSubprocessLoggerThread (cr^.crSubprocessLog) requestChan 219 220 -- End thread startup ---------------------------------------------- 221 222 -- For each team, build a team state and load the last-run state. 223 (teamStates, chanLists) <- unzip <$> mapM (buildTeamState cr me) teams 224 225 let startupState = 226 StartupStateInfo { startupStateResources = cr 227 , startupStateConnectedUser = me 228 , startupStateTimeZone = tz 229 , startupStateInitialHistory = hist 230 , startupStateInitialTeam = initialTeamId 231 , startupStateTeams = teamMap 232 } 233 clientChans = mconcat chanLists 234 st = newState startupState & csChannels .~ clientChans 235 teamMap = HM.fromList $ (\ts -> (teamId $ _tsTeam ts, ts)) <$> F.toList teamStates 236 237 loadFlaggedMessages (cr^.crUserPreferences.userPrefFlaggedPostList) st 238 239 -- Trigger an initial websocket refresh 240 writeBChan (cr^.crEventQueue) RefreshWebsocketEvent 241 242 return st 243