content: {-# 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 { _ciHostname = fromMaybe "" (configHost config)
                     , _ciPort     = configPort config
                     , _ciUrlPath  = fromMaybe "" (configUrlPath config)
                     , _ciUsername = fromMaybe "" (configUser config)
                     , _ciPassword = case configPass config of
                                         Just (PasswordString s) -> s
                                         _                       -> ""
                     , _ciOTPToken = case configOTPToken config of
                                         Just (OTPTokenString s) -> Just s
                                         _                       -> Just ""
                     , _ciAccessToken = case configToken config of
                                            Just (TokenString s) -> s
                                            _                    -> ""
                     , _ciType     = configConnectionType config
                     }
  
  apiLogEventToLogMessage :: LogEvent -> IO LogMessage
  apiLogEventToLogMessage ev = do
      now <- getCurrentTime
      let msg = T.pack $ "Function: " <> logFunction ev <>
                         ", event: " <> show (logEventType ev)
      return $ LogMessage { logMessageCategory = LogAPI
                          , logMessageText = msg
                          , logMessageContext = Nothing
                          , logMessageTimestamp = now
                          }
  
  setupState :: IO Vty.Vty -> Maybe FilePath -> Config -> IO (ChatState, Vty.Vty)
  setupState mkVty mLogLocation config = do
      initialVty <- mkVty
  
      eventChan <- newBChan 2500
      logMgr <- newLogManager eventChan (configLogMaxBufferSize config)
  
      -- If we got an initial log location, start logging there.
      case mLogLocation of
          Nothing -> return ()
          Just loc -> startLoggingToFile logMgr loc
  
      let logApiEvent ev = apiLogEventToLogMessage ev >>= sendLogMessage logMgr
          setLogger cd = cd `withLogger` logApiEvent
  
      (mLoginSuccess, loginVty) <- interactiveGetLoginSession initialVty mkVty
                                                              setLogger
                                                              logMgr
                                                              (incompleteCredentials config)
  
      let shutdown vty = do
              Vty.shutdown vty
              exitSuccess
  
      (session, me, cd, mbTeam) <- case mLoginSuccess of
          Nothing ->
              -- The user never attempted a connection and just chose to
              -- quit.
              shutdown loginVty
          Just (LoginSuccess cd sess user mbTeam) ->
              -- The user attempted a connection and succeeded so continue
              -- with setup.
              return (sess, user, cd, mbTeam)
  
      teams <- F.toList <$> mmGetUsersTeams UserMe session
      when (null teams) $ do
          putStrLn "Error: your account is not a member of any teams"
          exitFailure
  
      let initialTeamId = fromMaybe (teamId $ head teams) $ do
              tName <- mbTeam <|> configTeam config
              let matchingTeam = listToMaybe $ filter (matchesTeam tName) teams
              teamId <$> matchingTeam
  
      userStatusChan <- STM.newTChanIO
      slc <- STM.newTChanIO
      wac <- STM.newTChanIO
  
      prefs <- mmGetUsersPreferences UserMe session
      let userPrefs = setUserPreferences prefs defaultUserPreferences
          themeName = case configTheme config of
              Nothing -> internalThemeName defaultTheme
              Just t -> t
          baseTheme = internalTheme $ fromMaybe defaultTheme (lookupTheme themeName)
  
      -- Did the configuration specify a theme customization file? If so,
      -- load it and customize the theme.
      custTheme <- case configThemeCustomizationFile config of
          Nothing -> return baseTheme
          Just path ->
              -- If we have no configuration path (i.e. we used the default
              -- config) then ignore theme customization.
              let pathStr = T.unpack path
              in if isRelative pathStr && isNothing (configAbsPath config)
                 then return baseTheme
                 else do
                     let absPath = if isRelative pathStr
                                   then (dropFileName $ fromJust $ configAbsPath config) </> pathStr
                                   else pathStr
                     result <- loadCustomizations absPath baseTheme
                     case result of
                         Left e -> do
                             Vty.shutdown loginVty
                             putStrLn $ "Error loading theme customization from " <> show absPath <> ": " <> e
                             exitFailure
                         Right t -> return t
  
      requestChan <- STM.atomically STM.newTChan
  
      emoji <- either (const emptyEmojiCollection) id <$> do
          result1 <- loadEmoji =<< userEmojiJsonPath
          case result1 of
              Right e -> return $ Right e
              Left _ -> loadEmoji =<< bundledEmojiJsonPath
  
      spResult <- maybeStartSpellChecker config
  
      let cr = ChatResources { _crSession             = session
                             , _crWebsocketThreadId   = Nothing
                             , _crConn                = cd
                             , _crRequestQueue        = requestChan
                             , _crEventQueue          = eventChan
                             , _crSubprocessLog       = slc
                             , _crWebsocketActionChan = wac
                             , _crTheme               = themeToAttrMap custTheme
                             , _crThemeOriginal       = custTheme
                             , _crStatusUpdateChan    = userStatusChan
                             , _crConfiguration       = config
                             , _crFlaggedPosts        = mempty
                             , _crUserPreferences     = userPrefs
                             , _crSyntaxMap           = mempty
                             , _crLogManager          = logMgr
                             , _crEmoji               = emoji
                             , _crSpellChecker        = spResult
                             , _crWindowSize          = (0, 0)
                             }
  
      st <- initializeState cr initialTeamId teams me
  
      return (st, loginVty)
  
  initializeState :: ChatResources -> TeamId -> [Team] -> User -> IO ChatState
  initializeState cr initialTeamId teams me = do
      let session = getResourceSession cr
          requestChan = cr^.crRequestQueue
  
      tz <- fromRight utcTimezone <$> lookupLocalTimeZone
  
      hist <- do
          result <- readHistory
          case result of
              Left _ -> return newHistory
              Right h -> return h
  
      --------------------------------------------------------------------
      -- Start background worker threads:
      --
      --  * Syntax definition loader
      startSyntaxMapLoaderThread (cr^.crConfiguration) (cr^.crEventQueue)
  
      --  * Main async queue worker thread
      startAsyncWorkerThread (cr^.crConfiguration) (cr^.crRequestQueue) (cr^.crEventQueue)
  
      --  * User status thread
      startUserStatusUpdateThread (cr^.crStatusUpdateChan) session requestChan
  
      --  * Refresher for users who are typing currently
      when (configShowTypingIndicator (cr^.crConfiguration)) $
        startTypingUsersRefreshThread requestChan
  
      --  * Timezone change monitor
      startTimezoneMonitorThread tz requestChan
  
      --  * Subprocess logger
      startSubprocessLoggerThread (cr^.crSubprocessLog) requestChan
  
      -- End thread startup ----------------------------------------------
  
      -- For each team, build a team state and load that team's last-run
      -- state, if any.
      (teamStates, chanLists) <- unzip <$> mapM (buildTeamState cr me) teams
  
      let startupState =
              StartupStateInfo { startupStateResources      = cr
                               , startupStateConnectedUser  = me
                               , startupStateTimeZone       = tz
                               , startupStateInitialHistory = hist
                               , startupStateInitialTeam    = initialTeamId
                               , startupStateTeams          = teamMap
                               }
          clientChans = mconcat chanLists
          st = newState startupState & csChannels .~ clientChans
          teamMap = HM.fromList $ (\ts -> (teamId $ _tsTeam ts, ts)) <$> F.toList teamStates
  
      loadFlaggedMessages (cr^.crUserPreferences.userPrefFlaggedPostList) st
  
      -- Trigger an initial websocket refresh
      writeBChan (cr^.crEventQueue) RefreshWebsocketEvent
  
      return st
  