-- |

{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE LambdaCase #-}

module Gargantext.API.Admin.EnvTypes (
    GargJob(..)
  , Env(..)
  , Mode(..)
  , modeToLoggingLevels
  , mkJobHandle
  , env_config
  , env_logger
  , env_manager
  , env_self_url
  , env_central_exchange
  , env_dispatcher
  , env_jwt_settings
  
  , menv_firewall
  , dev_env_logger

  , FireWall(..)
  , MockEnv(..)
  , DevEnv(..)
  , DevJobHandle(..)
  , ConcreteJobHandle -- opaque
  ) where

import Control.Lens hiding (Level, (:<))
import Control.Monad.Except
import Control.Monad.Reader
import Data.List ((\\))
import Data.Pool (Pool)
import Data.Sequence (ViewL(..), viewl)
import Data.Text qualified as T
import Database.PostgreSQL.Simple (Connection)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Job
import Gargantext.API.Prelude (GargM, IsGargServer)
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.AsyncUpdates.Dispatcher (Dispatcher)
import Gargantext.Core.AsyncUpdates.Dispatcher.Types (HasDispatcher(..))
import Gargantext.Core.Config (GargConfig(..), gc_mail_config, gc_nlp_config, HasJWTSettings(..), HasConfig(..))
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap)
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude (HasConnectionPool(..))
import Gargantext.Prelude hiding (to)
import Gargantext.System.Logging
import Gargantext.Utils.Jobs.Internal (pollJob)
import Gargantext.Utils.Jobs.Map (LoggerM, J(..), jTask, rjGetLog)
import Gargantext.Utils.Jobs.Monad qualified as Jobs
import Network.HTTP.Client (Manager)
import Servant.Auth.Server (JWTSettings)
import Servant.Client (BaseUrl)
import Servant.Job.Async (HasJobEnv(..), Job)
import Servant.Job.Async qualified as SJ
import Servant.Job.Core qualified
import Servant.Job.Types qualified as SJ
import System.Log.FastLogger qualified as FL

data Mode = Dev | Mock | Prod
  deriving (Show, Read, Generic)

-- | Given the 'Mode' the server is running in, it returns the list of
-- allowed levels. For example for production we ignore everything which
-- has priority lower than "warning".
modeToLoggingLevels :: Mode -> [LogLevel]
modeToLoggingLevels = \case
   Dev  -> [minBound .. maxBound]
   Mock -> [minBound .. maxBound]
   -- For production, accepts everything but DEBUG.
   Prod -> [minBound .. maxBound] \\ [DEBUG]

instance MonadLogger (GargM Env BackendInternalError) where
  getLogger = asks _env_logger

instance HasLogger (GargM Env BackendInternalError) where
  data instance Logger (GargM Env BackendInternalError)  =
    GargLogger {
        logger_mode    :: Mode
      , logger_set     :: FL.LoggerSet
      }
  type instance LogInitParams (GargM Env BackendInternalError) = Mode
  type instance LogPayload (GargM Env BackendInternalError)    = FL.LogStr
  initLogger                = \mode -> do
    logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
    pure $ GargLogger mode logger_set
  destroyLogger             = \GargLogger{..}  -> liftIO $ FL.rmLoggerSet logger_set
  logMsg = \(GargLogger mode logger_set) lvl msg -> do
    let pfx = "[" <> show lvl <> "] " :: Text
    when (lvl `elem` (modeToLoggingLevels mode)) $
      liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
  logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)


data GargJob
  = TableNgramsJob
  | ForgotPasswordJob
  | UpdateNgramsListJobJSON
  | UpdateNgramsListJobTSV
  | AddContactJob
  | AddFileJob
  | DocumentFromWriteNodeJob
  | UpdateNodeJob
  | UploadFrameCalcJob
  | UploadDocumentJob
  | NewNodeJob
  | AddCorpusQueryJob
  | AddCorpusFormJob
  | AddCorpusFileJob
  | AddAnnuaireFormJob
  | RecomputeGraphJob
  deriving (Show, Eq, Ord, Enum, Bounded)

-- Do /not/ treat the data types of this type as strict, because it's convenient
-- to be able to partially initialise things like an 'Env' during tests, without
-- having to specify /everything/. This means that when we /construct/ an 'Env',
-- we need to remember to force the fields to WHNF at that point.
data Env = Env
  { _env_logger           :: ~(Logger (GargM Env BackendInternalError))
  , _env_pool             :: ~(Pool Connection)
  , _env_nodeStory        :: ~NodeStoryEnv
  , _env_manager          :: ~Manager
  , _env_self_url         :: ~BaseUrl
  , _env_scrapers         :: ~ScrapersEnv
  , _env_jobs             :: ~(Jobs.JobEnv GargJob (Seq JobLog) JobLog)
  , _env_config           :: ~GargConfig
  , _env_central_exchange :: ~ThreadId
  , _env_dispatcher       :: ~Dispatcher
  , _env_jwt_settings     :: ~JWTSettings
  }
  deriving (Generic)

makeLenses ''Env

instance HasConfig Env where
  hasConfig = env_config

instance HasConnectionPool Env where
  connPool = env_pool

instance HasNodeStoryEnv Env where
  hasNodeStory = env_nodeStory

instance HasNodeStoryImmediateSaver Env where
  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate

instance HasNodeArchiveStoryImmediateSaver Env where
  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate

instance HasJWTSettings Env where
  jwtSettings = env_jwt_settings

instance HasMail Env where
  mailSettings = env_config . gc_mail_config

instance HasNLPServer Env where
  nlpServer = env_config . gc_nlp_config . (to nlpServerMap)

instance HasDispatcher Env Dispatcher where
  hasDispatcher = env_dispatcher

instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
  _env = env_scrapers . Servant.Job.Core._env

instance HasJobEnv Env JobLog JobLog where
  job_env = env_scrapers

instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where
  getJobEnv = asks (view env_jobs)

instance CET.HasCentralExchangeNotification Env where
  ce_notify m = do
    c <- asks (view env_config)
    liftBase $ CE.notify (_gc_notifications_config c) m
    
-- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its
-- constructor it's not exported, to not leak internal details of its implementation.
data ConcreteJobHandle err =
    ConcreteNullHandle
  | JobHandle {
      _jh_id     :: !(SJ.JobID 'SJ.Safe)
    , _jh_logger :: LoggerM (GargM Env err) JobLog
    }

-- | Creates a new /concrete/ 'JobHandle', given its underlying 'JobID' and the logging function to
-- be used to report the status.
mkJobHandle :: SJ.JobID 'SJ.Safe
            -> LoggerM (GargM Env err) JobLog
            -> ConcreteJobHandle err
mkJobHandle jId = JobHandle jId

-- | Updates the status of a 'JobHandle' by using the input 'updateJobStatus' function.
updateJobProgress :: ConcreteJobHandle err -> (JobLog -> JobLog) -> GargM Env err ()
updateJobProgress ConcreteNullHandle _ = pure ()
updateJobProgress hdl@(JobHandle jId logStatus) updateJobStatus = do
  jobLog <- Jobs.getLatestJobStatus hdl
  let jobLogNew = updateJobStatus jobLog
  logStatus jobLogNew
  mJb <- Jobs.findJob jId
  case mJb of
    Nothing -> pure ()
    Just je -> do
      -- We use the same endpoint as the one for polling jobs via
      -- API. This way we can send the job status directly in the
      -- notification
      j <- pollJob (Just $ SJ.Limit 1) Nothing jId je
      CET.ce_notify $ CET.UpdateJobProgress j

instance Jobs.MonadJobStatus (GargM Env err) where

  type JobHandle      (GargM Env err) = ConcreteJobHandle err
  type JobType        (GargM Env err) = GargJob
  type JobOutputType  (GargM Env err) = JobLog
  type JobEventType   (GargM Env err) = JobLog

  noJobHandle Proxy = ConcreteNullHandle

  getLatestJobStatus ConcreteNullHandle = pure noJobLog
  getLatestJobStatus (JobHandle jId _) = do
    mb_jb <- Jobs.findJob jId
    case mb_jb of
      Nothing -> pure noJobLog
      Just j  -> case jTask j of
        QueuedJ _   -> pure noJobLog
        RunningJ rj -> liftIO (rjGetLog rj) <&>
                         \lgs -> case viewl lgs of
                                   EmptyL -> noJobLog
                                   l :< _ -> l
        DoneJ lgs _ -> pure $ case viewl lgs of
                                   EmptyL -> noJobLog
                                   l :< _ -> l

  withTracer _ ConcreteNullHandle f  = f ConcreteNullHandle
  withTracer extraLogger (JobHandle jId logger) n = n (JobHandle jId (\w -> logger w >> liftIO (extraLogger w)))

  markStarted n jh = updateJobProgress jh (const $ jobLogStart (RemainingSteps n))

  markProgress steps jh = updateJobProgress jh (jobLogProgress steps)

  markFailure steps mb_msg jh =
    updateJobProgress jh (\latest -> case mb_msg of
                                       Nothing  -> jobLogFailures steps latest
                                       Just msg -> addErrorEvent msg (jobLogFailures steps latest)
                         )

  markComplete jh = updateJobProgress jh jobLogComplete

  markFailed mb_msg jh =
    updateJobProgress jh (\latest -> case mb_msg of
                                       Nothing  -> jobLogFailTotal latest
                                       Just msg -> jobLogFailTotalWithMessage msg latest
                         )

  addMoreSteps steps jh = updateJobProgress jh (jobLogAddMore steps)

data FireWall = FireWall { unFireWall :: Bool }

data MockEnv = MockEnv
  { _menv_firewall :: !FireWall
  }
  deriving (Generic)

makeLenses ''MockEnv

instance MonadLogger (GargM DevEnv BackendInternalError) where
  getLogger = asks _dev_env_logger

instance HasLogger (GargM DevEnv BackendInternalError) where
  data instance Logger (GargM DevEnv BackendInternalError)  =
    GargDevLogger {
        dev_logger_mode    :: Mode
      , dev_logger_set     :: FL.LoggerSet
      }
  type instance LogInitParams (GargM DevEnv BackendInternalError) = Mode
  type instance LogPayload (GargM DevEnv BackendInternalError)    = FL.LogStr
  initLogger                = \mode -> do
    dev_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
    pure $ GargDevLogger mode dev_logger_set
  destroyLogger             = \GargDevLogger{..}  -> liftIO $ FL.rmLoggerSet dev_logger_set
  logMsg = \(GargDevLogger mode logger_set) lvl msg -> do
    let pfx = "[" <> show lvl <> "] " :: Text
    when (lvl `elem` (modeToLoggingLevels mode)) $
      liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
  logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)

data DevEnv = DevEnv
  { _dev_env_config    :: !GargConfig
  , _dev_env_logger    :: !(Logger (GargM DevEnv BackendInternalError))
  , _dev_env_pool      :: !(Pool Connection)
  , _dev_env_nodeStory :: !NodeStoryEnv
  }

makeLenses ''DevEnv

instance CET.HasCentralExchangeNotification DevEnv where
  ce_notify m = do
    nc <- asks (view dev_env_config)
    liftBase $ CE.notify (_gc_notifications_config nc) m

-- | Our /mock/ job handle.
data DevJobHandle = DevJobHandle

instance Jobs.MonadJobStatus (GargM DevEnv err) where

  type JobHandle (GargM DevEnv err) = DevJobHandle

  type JobType        (GargM DevEnv err) = GargJob
  type JobOutputType  (GargM DevEnv err) = JobLog
  type JobEventType   (GargM DevEnv err) = JobLog

  noJobHandle Proxy = DevJobHandle

  getLatestJobStatus DevJobHandle = pure noJobLog

  withTracer _ DevJobHandle n = n DevJobHandle

  markStarted _ _ = pure ()

  markProgress _ _ = pure ()

  markFailure _ _ _ = pure ()

  markComplete _ = pure ()

  markFailed _ _ = pure ()

  addMoreSteps _ _ = pure ()

instance HasConfig DevEnv where
  hasConfig = dev_env_config

instance HasConnectionPool DevEnv where
  connPool = dev_env_pool


instance HasNodeStoryEnv DevEnv where
  hasNodeStory = dev_env_nodeStory

instance HasNodeStoryImmediateSaver DevEnv where
  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate

instance HasNodeArchiveStoryImmediateSaver DevEnv where
  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate

instance HasMail DevEnv where
  mailSettings = dev_env_config . gc_mail_config

instance HasNLPServer DevEnv where
  nlpServer = dev_env_config . gc_nlp_config . (to nlpServerMap)


instance IsGargServer Env BackendInternalError (GargM Env BackendInternalError)
