module Polysemy.Hasql.Test.Database where

import qualified Data.UUID as UUID
import Data.UUID (UUID)
import Exon (exon)
import Hasql.Connection (Connection)
import Hasql.Session (QueryError)
import Polysemy.Db.Data.DbConfig (DbConfig (DbConfig))
import Polysemy.Db.Data.DbConnectionError (DbConnectionError)
import qualified Polysemy.Db.Data.DbError as DbError
import Polysemy.Db.Data.DbError (DbError)
import Polysemy.Db.Data.DbName (DbName (DbName))
import Polysemy.Db.Effect.Random (Random, random)
import Polysemy.Db.Interpreter.Random (interpretRandom)
import Time (GhcTime)
import Sqel.Data.PgTypeName (pattern PgTypeName, pgTableName)
import Sqel.Data.TableSchema (TableSchema)

import Polysemy.Hasql.Effect.Database (ConnectionSource, Database)
import qualified Polysemy.Hasql.Effect.DbConnectionPool as DbConnectionPool
import Polysemy.Hasql.Effect.DbConnectionPool (DbConnectionPool)
import Polysemy.Hasql.Interpreter.Database (interpretDatabase)
import Polysemy.Hasql.Interpreter.DbConnectionPool (interpretDbConnectionPool, interpretDbConnectionPoolSingle)
import Polysemy.Hasql.Session (convertQueryError, runStatement)
import qualified Polysemy.Hasql.Statement as Statement

suffixedTableSchema ::
  Text ->
  TableSchema d ->
  TableSchema d
suffixedTableSchema :: forall d. Text -> TableSchema d -> TableSchema d
suffixedTableSchema Text
suffix =
  #pg . #name %~ \ (PgTypeName name) -> pgTableName [exon|#{name}-#{suffix}|]

createTestDb ::
  Members [Random UUID, Stop DbError, Embed IO] r =>
  DbConfig ->
  Connection ->
  Sem r DbConfig
createTestDb :: forall (r :: EffectRow).
Members '[Random UUID, Stop DbError, Embed IO] r =>
DbConfig -> Connection -> Sem r DbConfig
createTestDb dbConfig :: DbConfig
dbConfig@(DbConfig DbHost
_ DbPort
_ (DbName Text
name) DbUser
_ DbPassword
_) Connection
connection = do
  Text
suffix <- UUID -> Text
UUID.toText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (r :: EffectRow). Member (Random a) r => Sem r a
random
  let
    suffixedName :: DbName
suffixedName = Text -> DbName
DbName [exon|#{name}-#{suffix}|]
    suffixed :: DbConfig
suffixed = DbConfig
dbConfig forall a b. a -> (a -> b) -> b
& forall a. IsLabel "name" a => a
#name forall s t a b. ASetter s t a b -> b -> s -> t
.~ DbName
suffixedName
  DbConfig
suffixed forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (r :: EffectRow) p a.
Members '[Stop DbError, Embed IO] r =>
Connection -> p -> Statement p a -> Sem r a
runStatement Connection
connection () (DbName -> Statement () ()
Statement.createDb DbName
suffixedName)

withTestDb ::
  Members [Stop DbError, Resource, Mask, Race, Embed IO, Final IO] r =>
  DbConfig ->
  (DbConfig -> Sem r a) ->
  Sem r a
withTestDb :: forall (r :: EffectRow) a.
Members
  '[Stop DbError, Resource, Mask, Race, Embed IO, Final IO] r =>
DbConfig -> (DbConfig -> Sem r a) -> Sem r a
withTestDb DbConfig
baseConfig DbConfig -> Sem r a
f =
  forall (r :: EffectRow).
Member (Embed IO) r =>
DbConfig
-> InterpreterFor (Resumable DbConnectionError DbConnectionPool) r
interpretDbConnectionPoolSingle DbConfig
baseConfig do
    forall err (eff :: (* -> *) -> * -> *) err' (r :: EffectRow) a.
Members '[Resumable err eff, Stop err'] r =>
(err -> err') -> Sem (eff : r) a -> Sem r a
resumeHoist DbConnectionError -> DbError
DbError.Connection forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow).
Member DbConnectionPool r =>
ConnectionTag -> Sem r Connection
DbConnectionPool.acquire ConnectionTag
"test" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Connection
connection ->
      forall (r :: EffectRow) a c b.
Member Resource r =>
Sem r a -> (a -> Sem r c) -> (a -> Sem r b) -> Sem r b
bracket (forall {r :: EffectRow}.
(Member (Embed IO) r, Member (Stop DbError) r) =>
DbConfig -> Connection -> Sem r DbConfig
acquire DbConfig
baseConfig Connection
connection) (forall {r :: EffectRow}.
(Member (Stop DbError) r, Member (Embed IO) r) =>
Connection -> DbConfig -> Sem r ()
release Connection
connection) (forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbConfig -> Sem r a
f)
  where
    acquire :: DbConfig -> Connection -> Sem r DbConfig
acquire DbConfig
config Connection
connection =
      forall a (r :: EffectRow).
(Random a, Member (Embed IO) r) =>
InterpreterFor (Random a) r
interpretRandom forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow).
Members '[Random UUID, Stop DbError, Embed IO] r =>
DbConfig -> Connection -> Sem r DbConfig
createTestDb DbConfig
config Connection
connection
    release :: Connection -> DbConfig -> Sem r ()
release Connection
connection (DbConfig DbHost
_ DbPort
_ DbName
name DbUser
_ DbPassword
_) =
      forall err e' (r :: EffectRow) a.
Member (Stop e') r =>
(err -> e') -> Sem (Stop err : r) a -> Sem r a
mapStop QueryError -> DbError
convertQueryError (forall (r :: EffectRow) p a.
Members '[Stop DbError, Embed IO] r =>
Connection -> p -> Statement p a -> Sem r a
runStatement Connection
connection () (DbName -> Statement () ()
Statement.dropDb DbName
name))

type TestConnectionEffects =
  [
    Database !! DbError,
    Scoped ConnectionSource (Database !! DbError),
    DbConnectionPool !! DbConnectionError
  ]

withTestConnection ::
  Members [Stop DbError, Time t dt, Log, Resource, Mask, Race, Embed IO, Final IO] r =>
  DbConfig ->
  InterpretersFor TestConnectionEffects r
withTestConnection :: forall t dt (r :: EffectRow).
Members
  '[Stop DbError, Time t dt, Log, Resource, Mask, Race, Embed IO,
    Final IO]
  r =>
DbConfig -> InterpretersFor TestConnectionEffects r
withTestConnection DbConfig
baseConfig Sem (Append TestConnectionEffects r) a
ma =
  forall (r :: EffectRow) a.
Members
  '[Stop DbError, Resource, Mask, Race, Embed IO, Final IO] r =>
DbConfig -> (DbConfig -> Sem r a) -> Sem r a
withTestDb DbConfig
baseConfig \ DbConfig
dbConfig ->
    forall (r :: EffectRow).
Members '[Log, Resource, Embed IO, Final IO] r =>
DbConfig
-> Maybe Int
-> Maybe Int
-> InterpreterFor (Resumable DbConnectionError DbConnectionPool) r
interpretDbConnectionPool DbConfig
dbConfig forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
    forall t d (r :: EffectRow).
Members
  '[Resumable DbConnectionError DbConnectionPool, Time t d, Resource,
    Log, Mask, Race, Embed IO, Final IO]
  r =>
InterpretersFor
  '[Database !! DbError,
    Scoped ConnectionSource (Database !! DbError)]
  r
interpretDatabase forall a b. (a -> b) -> a -> b
$
    Sem (Append TestConnectionEffects r) a
ma

type TestStoreDeps =
  [
    Resource,
    Embed IO,
    Scoped ConnectionSource (Database !! DbError),
    Database !! DbError,
    Error DbError,
    Random UUID,
    Log,
    Stop QueryError,
    Stop DbError,
    GhcTime
  ]