{-|
Module      : Test.Database.Types
Description : GarganText tests
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX
-}

{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans      #-}
{-# LANGUAGE TypeApplications #-}

module Test.Database.Types where

import Control.Exception.Safe
import Control.Lens
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.IORef
import Data.Map qualified as Map
import Data.Pool
import Database.PostgreSQL.Simple qualified as PG
import Database.Postgres.Temp qualified as Tmp
import Gargantext hiding (throwIO, to)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Core.Config
import Gargantext.Core.Config.Mail (MailConfig(..), LoginType(NoAuth), SendEmailType(LogEmailToConsole))
import Gargantext.Core.Mail.Types (HasMail(..))
import Gargantext.Core.NLP (HasNLPServer(..))
import Gargantext.Core.NodeStory
import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..), LogLevel(..))
import Gargantext.System.Logging.Loggers
import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
import Network.URI (parseURI)
import Prelude qualified
import System.Log.FastLogger qualified as FL
import System.IO.Error (userError)


newtype Counter = Counter { _Counter :: IORef Int }
  deriving Eq

instance Prelude.Show Counter where
  show (Counter _) = "Counter"

emptyCounter :: IO Counter
emptyCounter = Counter <$> newIORef 0

nextCounter :: Counter -> IO Int
nextCounter (Counter ref) = atomicModifyIORef' ref (\old -> (succ old, old))

data TestEnv = TestEnv {
    test_db                  :: !DBHandle
  , test_config              :: !GargConfig
  , test_nodeStory           :: !(NodeStoryEnv BackendInternalError)
  , test_usernameGen         :: !Counter
  , test_logger              :: !(Logger (GargM TestEnv BackendInternalError))
  , test_worker_tid          :: !ThreadId
  }

newtype TestMonadM env err a = TestMonad { _TestMonad :: ExceptT err (ReaderT env IO) a }
  deriving ( Functor, Applicative, Monad
           , MonadReader env
           , MonadBase IO
           , MonadError err
           , MonadBaseControl IO
           , MonadFail
           , MonadIO
           , MonadMask
           , MonadCatch
           , MonadThrow
           )

instance HasLogger (TestMonadM TestEnv err) where
  data instance Logger (TestMonadM TestEnv err)        = TestLogger { _IOLogger :: IOStdLogger }
  type instance LogInitParams (TestMonadM TestEnv err) = LogConfig
  type instance LogPayload (TestMonadM TestEnv err)    = Prelude.String
  initLogger cfg = fmap TestLogger $ (liftIO $ ioStdLogger cfg)
  destroyLogger = liftIO . _iosl_destroy . _IOLogger
  logMsg (TestLogger ioLogger) lvl msg = liftIO $ _iosl_log_msg ioLogger lvl msg
  logTxt (TestLogger ioLogger) lvl msg = liftIO $ _iosl_log_txt ioLogger lvl msg

instance MonadLogger (TestMonadM TestEnv BackendInternalError) where
  getLogger = TestMonad $ do
    initLogger @(TestMonadM TestEnv BackendInternalError) (LogConfig Nothing ERROR)

runTestMonadM :: Show err => env -> TestMonadM env err a -> IO a
runTestMonadM env m = do
  res <- flip runReaderT env . runExceptT . _TestMonad $ m
  case res of
    Left err -> throwIO $ userError (show err)
    Right x  -> pure x

runTestMonad :: TestEnv -> TestMonadM TestEnv BackendInternalError a -> IO a
runTestMonad env m = do
  res <- flip runReaderT env . runExceptT . _TestMonad $ m
  case res of
    Left err -> throwIO $ userError ("runTestMonad: " <> show err)
    Right x  -> pure x

type TestMonad = TestMonadM TestEnv BackendInternalError
data TestJobHandle = TestNoJobHandle

instance MonadJobStatus TestMonad where
  type JobHandle      TestMonad = TestJobHandle
  type JobOutputType  TestMonad = JobLog
  type JobEventType   TestMonad = JobLog

  noJobHandle _         = TestNoJobHandle
  getLatestJobStatus _  = TestMonad (pure noJobLog)
  withTracer _ jh n     = n jh
  markStarted _ _       = TestMonad $ pure ()
  markProgress _ _      = TestMonad $ pure ()
  markFailure _ _ _     = TestMonad $ pure ()
  markComplete _        = TestMonad $ pure ()
  markFailed _ _        = TestMonad $ pure ()
  emitWarning _ _       = TestMonad $ pure ()
  addMoreSteps _ _      = TestMonad $ pure ()

data DBHandle = DBHandle {
    _DBHandle :: Pool PG.Connection
  , _DBTmp    :: Tmp.DB
  }

instance HasConnectionPool DBHandle where
  connPool = to _DBHandle

instance HasConnectionPool TestEnv where
  connPool = to (_DBHandle . test_db)

instance HasConfig TestEnv where
  hasConfig = to test_config

instance HasMail TestEnv where
  mailSettings = to $ const (MailConfig { _mc_mail_host         = "localhost"
                                        , _mc_mail_port         = 25
                                        , _mc_mail_user         = "test"
                                        , _mc_mail_from         = "test@localhost"
                                        , _mc_mail_password     = "test"
                                        , _mc_mail_login_type   = NoAuth
                                        , _mc_send_login_emails = LogEmailToConsole })

instance HasNodeStoryEnv TestEnv BackendInternalError where
  hasNodeStory = to test_nodeStory

coreNLPConfig :: NLPServerConfig
coreNLPConfig =
  let uri = parseURI "http://localhost:9000"
  in NLPServerConfig CoreNLP (fromMaybe (errorTrace "parseURI for nlpServerConfig failed") uri)


instance HasNLPServer TestEnv where
  nlpServer = to $ const (Map.singleton EN coreNLPConfig)

instance MonadLogger (GargM TestEnv BackendInternalError) where
  getLogger = asks test_logger

instance HasLogger (GargM TestEnv BackendInternalError) where
  newtype instance Logger (GargM TestEnv BackendInternalError) =
    GargTestLogger { _GargTestLogger :: MonadicStdLogger FL.LogStr IO }
  type instance LogInitParams (GargM TestEnv BackendInternalError) = LogConfig
  type instance LogPayload (GargM TestEnv BackendInternalError)    = FL.LogStr
  initLogger cfg = fmap GargTestLogger $ (liftIO $ monadicStdLogger cfg)
  destroyLogger = liftIO . _msl_destroy . _GargTestLogger
  logMsg (GargTestLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
  logTxt (GargTestLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
