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