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 ]