{-# 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 = Nothing
                   , _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 $ sortTeams 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

    let cr = ChatResources { _crSession             = session
                           , _crWebsocketThreadId   = Nothing
                           , _crConn                = cd
                           , _crRequestQueue        = requestChan
                           , _crEventQueue          = eventChan
                           , _crSubprocessLog       = slc
                           , _crWebsocketActionChan = wac
                           , _crTheme               = themeToAttrMap custTheme
                           , _crStatusUpdateChan    = userStatusChan
                           , _crConfiguration       = config
                           , _crFlaggedPosts        = mempty
                           , _crUserPreferences     = userPrefs
                           , _crSyntaxMap           = mempty
                           , _crLogManager          = logMgr
                           , _crEmoji               = emoji
                           }

    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