{-|
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.Except
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 GHC.IO.Exception (userError)
import Gargantext hiding (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


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 :: ReaderT env IO a }
  deriving ( Functor, Applicative, Monad
           , MonadReader env
           , MonadBase IO
           , MonadBaseControl IO
           , MonadFail
           , MonadIO
           , MonadMask
           , MonadCatch
           , MonadThrow
           )

instance HasLogger (TestMonadM TestEnv BackendInternalError) where
  data instance Logger (TestMonadM TestEnv BackendInternalError)        = TestLogger { _IOLogger :: IOStdLogger }
  type instance LogInitParams (TestMonadM TestEnv BackendInternalError) = LogConfig
  type instance LogPayload (TestMonadM TestEnv BackendInternalError)    = 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 :: env -> TestMonadM env err a -> IO a
runTestMonadM env = flip runReaderT env . _TestMonad

runTestMonad :: TestEnv -> TestMonadM TestEnv BackendInternalError a -> IO a
runTestMonad env = flip runReaderT env . _TestMonad

-- | Shoehorn a BackendInternalError into an IOException, suitable
-- for testing.
instance MonadError BackendInternalError (TestMonadM env BackendInternalError) where
  throwError e = TestMonad $ throwError (userError $ show e)
  catchError (TestMonad m) hdl =
    TestMonad $ ReaderT $ \e -> catchError (flip runReaderT e m) (\e' -> runTestMonadM e $ hdl (InternalWorkerError e'))

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
