{-|
Module      : Gargantext.Core.Worker.Env
Description : Asynchronous worker logic (environment)
Copyright   : (c) CNRS, 2024
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans      #-}  -- orphan HasNodeError IOException


module Gargantext.Core.Worker.Env where


import Control.Lens (prism', to, view)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Pool (Pool)
import Data.Text qualified as T
import Database.PostgreSQL.Simple (Connection)
import Gargantext.API.Admin.EnvTypes (ConcreteJobHandle, GargJob, Mode(Dev), modeToLoggingLevels)
import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
import Gargantext.API.Admin.Settings ( devSettings, newPool )
import Gargantext.API.Admin.Types (HasSettings(..), Settings(..))
import Gargantext.API.Prelude (GargM)
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.Config (GargConfig(..), HasConfig(..))
import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.Mail.Types (HasMail(..))
import Gargantext.Core.NLP (HasNLPServer(..), NLPServerMap, nlpServerMap)
import Gargantext.Core.NodeStory (HasNodeStoryEnv(..), HasNodeStoryImmediateSaver(..), HasNodeArchiveStoryImmediateSaver(..), NodeStoryEnv, fromDBNodeStoryEnv, nse_saver_immediate, nse_archive_saver_immediate)
import Gargantext.Core.Types (HasValidationError(..))
import Gargantext.Database.Prelude (HasConnectionPool(..))
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Tree.Error (HasTreeError(..))
import Gargantext.Prelude hiding (to)
import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..), withLoggerHoisted)
import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))
import Prelude qualified
import System.Log.FastLogger qualified as FL


data WorkerEnv = WorkerEnv
  { _w_env_settings  :: !Settings
  , _w_env_config    :: !GargConfig
  , _w_env_logger    :: !(Logger (GargM WorkerEnv IOException))
  , _w_env_pool      :: !(Pool Connection)
  , _w_env_nodeStory :: !NodeStoryEnv
  , _w_env_mail      :: !Mail.MailConfig
  , _w_env_nlp       :: !NLPServerMap
  }


withWorkerEnv :: SettingsFile -> (WorkerEnv -> IO a) -> IO a
withWorkerEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
  env <- newWorkerEnv logger
  k env -- `finally` cleanEnv env

  where
    newWorkerEnv logger = do
      cfg     <- readConfig         settingsFile
      --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
      pool    <- newPool            $ _gc_database_config cfg
      nodeStory_env <- fromDBNodeStoryEnv pool
      let setts = devSettings
      pure $ WorkerEnv
        { _w_env_pool      = pool
        , _w_env_logger    = logger
        , _w_env_nodeStory = nodeStory_env
        , _w_env_settings  = setts
        , _w_env_config    = cfg
        , _w_env_mail      = _gc_mail_config cfg
        , _w_env_nlp       = nlpServerMap $ _gc_nlp_config cfg
        }

instance HasConfig WorkerEnv where
  hasConfig = to _w_env_config

instance HasSettings WorkerEnv where
  settings = to _w_env_settings

instance HasLogger (GargM WorkerEnv IOException) where
  data instance Logger (GargM WorkerEnv IOException)  =
    GargWorkerLogger {
        w_logger_mode    :: Mode
      , w_logger_set     :: FL.LoggerSet
      }
  type instance LogInitParams (GargM WorkerEnv IOException) = Mode
  type instance LogPayload (GargM WorkerEnv IOException)    = FL.LogStr
  initLogger                = \mode -> do
    w_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
    pure $ GargWorkerLogger mode w_logger_set
  destroyLogger = \GargWorkerLogger{..}  -> liftIO $ FL.rmLoggerSet w_logger_set
  logMsg = \(GargWorkerLogger 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)

instance HasConnectionPool WorkerEnv where
  connPool = to _w_env_pool

instance HasMail WorkerEnv where
  mailSettings = to _w_env_mail

instance HasNLPServer WorkerEnv where
  nlpServer = to _w_env_nlp

instance HasNodeStoryEnv WorkerEnv where
  hasNodeStory = to _w_env_nodeStory

instance HasNodeStoryImmediateSaver WorkerEnv where
  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate

instance HasNodeArchiveStoryImmediateSaver WorkerEnv where
  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate

instance MonadLogger (GargM WorkerEnv IOException) where
  getLogger = asks _w_env_logger

instance CET.HasCentralExchangeNotification WorkerEnv where
  ce_notify m = do
    c <- asks (view $ to _w_env_config)
    liftBase $ CE.notify (_gc_notifications_config c) m

---------
instance HasValidationError IOException where
  _ValidationError = prism' mkIOException (const Nothing)
    where
      mkIOException v = IOError { ioe_handle = Nothing
                                , ioe_type = OtherError
                                , ioe_location = "Worker job (validation)"
                                , ioe_description = show v
                                , ioe_errno = Nothing
                                , ioe_filename = Nothing }

instance HasTreeError IOException where
  _TreeError = prism' mkIOException (const Nothing)
    where
      mkIOException v = IOError { ioe_handle = Nothing
                                , ioe_type = OtherError
                                , ioe_location = "Worker job (tree)"
                                , ioe_description = show v
                                , ioe_errno = Nothing
                                , ioe_filename = Nothing }

instance HasNodeError IOException where
  _NodeError = prism' (Prelude.userError . show) (const Nothing)

---------------

newtype WorkerMonad a =
  WorkerMonad { _WorkerMonad :: GargM WorkerEnv IOException a }
  deriving ( Functor
           , Applicative
           , Monad
           , MonadIO
           , MonadReader WorkerEnv
           , MonadBase IO
           , MonadBaseControl IO
           , MonadError IOException
           , MonadFail )

instance HasLogger WorkerMonad where
  data instance Logger WorkerMonad =
    WorkerMonadLogger {
        wm_logger_mode    :: Mode
      , wm_logger_set     :: FL.LoggerSet
      }
  type instance LogInitParams WorkerMonad = Mode
  type instance LogPayload WorkerMonad    = FL.LogStr
  initLogger                = \mode -> do
    wm_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
    pure $ WorkerMonadLogger mode wm_logger_set
  destroyLogger = \WorkerMonadLogger{..}  -> liftIO $ FL.rmLoggerSet wm_logger_set
  logMsg = \(WorkerMonadLogger 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)

instance MonadLogger WorkerMonad where
  getLogger = do
    env <- ask
    let (GargWorkerLogger { .. }) = _w_env_logger env
    pure $ WorkerMonadLogger { wm_logger_mode = w_logger_mode
                             , wm_logger_set = w_logger_set }

runWorkerMonad :: WorkerEnv -> WorkerMonad a -> IO a
runWorkerMonad env m = do
  res <- runExceptT . flip runReaderT env $ _WorkerMonad m
  case res of
    Left e -> throwIO e
    Right x -> pure x



data WorkerJobHandle = WorkerNoJobHandle

instance MonadJobStatus WorkerMonad where
  -- type JobHandle      WorkerMonad = WorkerJobHandle
  type JobHandle      WorkerMonad = ConcreteJobHandle IOException
  type JobType        WorkerMonad = GargJob
  type JobOutputType  WorkerMonad = JobLog
  type JobEventType   WorkerMonad = JobLog

  -- noJobHandle _         = WorkerNoJobHandle
  -- noJobHandle _         = noJobHandle (Proxy :: Proxy (GargM WorkerEnv IOException))  -- ConcreteNullHandle
  noJobHandle _ = noJobHandle (Proxy :: Proxy WorkerMonad)
  getLatestJobStatus _  = WorkerMonad (pure noJobLog)
  withTracer _ jh n     = n jh
  markStarted _ _       = WorkerMonad $ pure ()
  markProgress _ _      = WorkerMonad $ pure ()
  markFailure _ _ _     = WorkerMonad $ pure ()
  markComplete _        = WorkerMonad $ pure ()
  markFailed _ _        = WorkerMonad $ pure ()
  addMoreSteps _ _      = WorkerMonad $ pure ()
