{-|
Module      : Gargantext.Database.Prelude
Description : Specific Prelude for Database management
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

module Gargantext.Database.Prelude
  ( -- * Types and Constraints
    -- $typesAndConstraints
    --
    -- ** Environment Constraints
    HasConnectionPool(..)
  , IsDBEnv
  , IsDBEnvExtra
    -- ** Command Monad Constraints
  , IsCmd
  , IsDBCmd
  , IsDBCmdExtra
    -- ** Existential Versions of the Above Constraints, for Convenience
  , Cmd
  , CmdRandom
  , DBCmd
  , DBCmdWithEnv
  , DBCmdExtra
    -- ** Miscellaneous Type(s)
  , JSONB
    -- * Functions
    -- ** Executing DB Queries
    -- *** PostgreSQL.Simple
  , execPGSQuery
  , runPGSQuery
  , runPGSQuery_
    -- *** Opaleye
  , runOpaQuery
  , runCountOpaQuery
    -- ** Other Functions
  , runCmd
  , createDBIfNotExists
  , dbCheck
  , formatPGSQuery
  , fromField'
  , mkCmd
  , restrictMaybe
  )
where

import Control.Exception.Safe (throw)
import Control.Lens (Getter, view)
import Control.Monad.Random ( MonadRandom )
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson (Result(..))
import Data.ByteString qualified as DB
import Data.List qualified as DL
import Data.Pool (Pool, withResource)
import Data.Profunctor.Product.Default (Default)
import Database.PostgreSQL.Simple (Connection)
import Database.PostgreSQL.Simple qualified as PGS
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal  (Field)
import Database.PostgreSQL.Simple.Types (Query(..))
import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
import Gargantext.Core.Config (HasConfig(..))
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Prelude
import Opaleye (FromFields, Select, runSelect, SqlJsonb, DefaultFromField, toFields, matchMaybe, MaybeFields)
import Opaleye.Aggregate (countRows)
import Opaleye.Internal.Constant qualified
import Opaleye.Internal.Operators qualified
import Shelly qualified as SH


-- $typesAndConstraints
--
-- The names of the constraints and types in this module are chosen based on
-- the following guidelines:
-- * By default, constraints are relatively lenient. Stricter constraints are
--   obtained by appending the `Extra` suffix to the minimal constraint name.
-- * `IsDBEnv(Extra)` applies to the environment; the basic constraint allows
--   access to the database, and the `Extra` variant offers some more
--   capabilities such as access to mail.
-- * `IsCmd` is the basic constraint for command monads. Append `DB` to it to get
--   a monad of commands that can talk to the database. Append `Extra` to get
--   the ability to send mail, make use of the NLP server and deal with central
--   exchange notifications. Append `Random` to get access to randomness.
-- * Existential versions of the constraints bear the same name as the constraint
--   they are based on, but without the `Is` prefix.

class HasConnectionPool env where
  connPool :: Getter env (Pool Connection)

instance HasConnectionPool (Pool Connection) where
  connPool = identity

-- | The most basic constraints for an environment with a database.
-- If possible, try to not add more constraints here. When performing
-- a query/update on the DB, one shouldn't need more than being able to
-- fetch from the underlying 'env' the connection pool and access the
-- 'GargConfig' for some sensible defaults to store into the DB.
type IsDBEnv env =
  ( HasConnectionPool env
  , HasConfig         env
  )

-- | Constraints for a full-fledged environment, with a database, mail exchange,
-- NLP processing, notifications.
type IsDBEnvExtra env =
  ( IsDBEnv                            env
  , HasMail                            env
  , HasNLPServer                       env
  , CET.HasCentralExchangeNotification env
  )

-- | The most general constraints for commands. To interact with the database,
-- or access extra features (such as sending mail), you'll need to add some more
-- constraints (see the rest of this module)
type IsCmd env err m =
  ( MonadReader     env     m
  , MonadError          err m
  , MonadBaseControl IO     m
  )

-- | Only the /minimum/ amount of class constraints required
-- to use the Gargantext Database. It's important, to ease testability,
-- that these constraints stays as few as possible.
type IsDBCmd env err m =
  ( IsCmd env err m
  , IsDBEnv env
  )

-- | Full-fledged command class. Types in this class provide commands that can
-- interact with the database, perform NLP processing, etc.
type IsDBCmdExtra env err m =
  ( IsCmd        env err m
  , IsDBEnvExtra env
  )

-- | Basic command with access to randomness. It feels a little ad hoc to have
-- such a constraint instead of substituting it (and its counterpart existential
-- type `CmdRandom`) with its definition every time it appears in the codebase,
-- but I tried to doing that substitution and it wasn't so easy.
type IsCmdRandom env err m =
  ( IsCmd env err m
  , MonadRandom   m
  )

-- | Barebones command type, without any built-in ability to interact with the
-- database or do stuff like email exchanges.
type Cmd env err a = forall m. IsCmd env err m => m a

-- | Basic command type with access to randomness
type CmdRandom env err a = forall m. IsCmdRandom  env err m => m a

-- | Command type that allows for interaction with the database.
type DBCmd err a = forall m env. IsDBCmd env err m => m a

-- | Command type that allows for interaction with the database. Similar to
-- `DBCmd`, except you can constraint the environment type some more.
type DBCmdWithEnv env err a = forall m. IsDBCmd env err m => m a

-- | Full-fledged command types, with access to the database, mail, NLP
-- processing and central exchange notifications.
type DBCmdExtra err a = forall m env. IsDBCmdExtra env err m => m a

type JSONB = DefaultFromField SqlJsonb

fromInt64ToInt :: Int64 -> Int
fromInt64ToInt = fromIntegral

-- TODO: ideally there should be very few calls to this functions.
mkCmd :: (Connection -> IO a) -> DBCmd err a
mkCmd k = do
  pool <- view connPool
  liftBase $ withResource pool (liftBase . k)

runCmd :: env
       -> CmdRandom env err a
       -> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env

runOpaQuery :: Default FromFields fields haskells
            => Select fields
            -> DBCmd err [haskells]
runOpaQuery q = mkCmd $ \c -> runSelect c q

runCountOpaQuery :: Select a -> DBCmd err Int
runCountOpaQuery q = do
  counts <- mkCmd $ \c -> runSelect c $ countRows q
  -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
  pure $ fromInt64ToInt $ DL.head counts

formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err DB.ByteString
formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a

runPGSQuery :: ( PGS.FromRow r, PGS.ToRow q )
            => PGS.Query -> q -> DBCmd err [r]
runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
  where
    printError c (SomeException e) = do
      q' <- PGS.formatQuery c q a
      hPutStrLn stderr q'
      throw (SomeException e)

-- | TODO catch error
runPGSQuery_ :: ( PGS.FromRow r )
             => PGS.Query -> DBCmd err [r]
runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
  where
    printError (SomeException e) = do
      hPutStrLn stderr (fromQuery q)
      throw (SomeException e)

execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err Int64
execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a


fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
fromField' field mb = do
    v <- fromField field mb
    valueToHyperdata v
      where
          valueToHyperdata v = case fromJSON v of
             Success a  -> pure a
             Error _err -> returnError ConversionFailed field
                         $ DL.unwords [ "cannot parse hyperdata for JSON: "
                                      , show v
                                      ]

dbCheck :: DBCmd err Bool
dbCheck = do
  r :: [PGS.Only Text] <- runPGSQuery_ "select username from public.auth_user"
  case r of
    [] -> pure False
    _  -> pure True

restrictMaybe :: ( Default Opaleye.Internal.Operators.IfPP b b
                 , (Default Opaleye.Internal.Constant.ToFields Bool b))
              => MaybeFields a -> (a -> b) -> b
restrictMaybe v cond = matchMaybe v $ \case
  Nothing -> toFields True
  Just v' -> cond v'


-- | Creates a PostgreSQL DB if it doesn't exist.
--   Accepts a pg connection string and db name as argument.
createDBIfNotExists :: Text -> Text -> IO ()
createDBIfNotExists connStr dbName = do
  -- For the \gexec trick, see:
  -- https://stackoverflow.com/questions/18389124/simulate-create-database-if-not-exists-for-postgresql
  (_res, _ec) <- SH.shelly $ SH.silently $ SH.escaping False $ do
    let sql = "\"SELECT 'CREATE DATABASE " <> dbName <> "' WHERE NOT EXISTS (SELECT FROM pg_database WHERE datname = '" <> dbName <> "')\\gexec\""
    result <- SH.run "echo" [sql, "|", "psql", "-d", "\"" <> connStr <> "\""]
    (result,) <$> SH.lastExitCode
    
  return ()