module Polysemy.Hasql.Test.Run where import Conc (interpretMaskFinal, interpretRace) import Data.UUID (UUID) import Exon (exon) import Hasql.Session (QueryError) import Hedgehog (TestT) import Hedgehog.Internal.Property (Failure) import Log (Severity (Error), interpretLogStdoutLevelConc) import Polysemy.Db (interpretRandom) import Polysemy.Db.Data.DbConfig (DbConfig (DbConfig)) import Polysemy.Db.Data.DbConnectionError (DbConnectionError) import Polysemy.Db.Data.DbError (DbError) import Polysemy.Db.Data.InitDbError (InitDbError) import Polysemy.Db.Effect.Random (Random) import qualified Polysemy.Test as Hedgehog import Polysemy.Test (Hedgehog, Test, runTestAuto) import Polysemy.Test.Data.TestError (TestError) import Time (GhcTime, interpretTimeGhc) import System.Environment (lookupEnv) import Polysemy.Hasql.Test.Database (TestConnectionEffects, withTestConnection) type DbErrors = [ Stop DbConnectionError, Stop DbError, Stop QueryError, Stop Text, Error InitDbError, Error DbError ] type TestEffects = DbErrors ++ [ GhcTime, Random UUID, Log, Error Text, Mask, Race, Async, Test, Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO, Resource, Final IO ] dbConfig :: MonadIO m => String -> Text -> m (Maybe DbConfig) dbConfig :: forall (m :: * -> *). MonadIO m => String -> Text -> m (Maybe DbConfig) dbConfig String envPrefix Text name = do forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse String -> m DbConfig cons forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< (forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (String -> IO (Maybe String) lookupEnv [exon|#{envPrefix}_test_host|])) where cons :: String -> m DbConfig cons String host = do DbPort port <- String -> m DbPort parsePort forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< (forall a. a -> Maybe a -> a fromMaybe String "4321" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (String -> IO (Maybe String) lookupEnv [exon|#{envPrefix}_test_port|])) pure (DbHost -> DbPort -> DbName -> DbUser -> DbPassword -> DbConfig DbConfig (forall a. IsString a => String -> a fromString String host) DbPort port (forall a. IsString a => Text -> a fromText Text name) (forall a. IsString a => Text -> a fromText Text name) (forall a. IsString a => Text -> a fromText Text name)) parsePort :: String -> m DbPort parsePort String p = case forall a. Read a => String -> Maybe a readMaybe String p of Just DbPort a -> forall (f :: * -> *) a. Applicative f => a -> f a pure DbPort a Maybe DbPort Nothing -> forall a. HasCallStack => String -> a error [exon|invalid port in env var $#{envPrefix}_test_port: #{p}|] runIntegrationTestWith :: Members [Error Text, Embed IO] r => HasCallStack => String -> Text -> (DbConfig -> Sem (DbErrors ++ r) ()) -> Sem r () runIntegrationTestWith :: forall (r :: EffectRow). (Members '[Error Text, Embed IO] r, HasCallStack) => String -> Text -> (DbConfig -> Sem (DbErrors ++ r) ()) -> Sem r () runIntegrationTestWith String envPrefix Text name DbConfig -> Sem (DbErrors ++ r) () run = forall a. HasCallStack => (HasCallStack => a) -> a withFrozenCallStack do forall (m :: * -> *). MonadIO m => String -> Text -> m (Maybe DbConfig) dbConfig String envPrefix Text name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Just DbConfig conf -> forall e1 e2 (r :: EffectRow) a. Member (Error e2) r => (e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a mapError @DbError @Text forall b a. (Show a, IsString b) => a -> b show forall a b. (a -> b) -> a -> b $ forall e1 e2 (r :: EffectRow) a. Member (Error e2) r => (e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a mapError @InitDbError @Text forall b a. (Show a, IsString b) => a -> b show forall a b. (a -> b) -> a -> b $ forall err (r :: EffectRow) a. Member (Error err) r => Sem (Stop err : r) a -> Sem r a stopToError @Text forall a b. (a -> b) -> a -> b $ forall err e' (r :: EffectRow) a. Member (Stop e') r => (err -> e') -> Sem (Stop err : r) a -> Sem r a mapStop @QueryError @Text forall b a. (Show a, IsString b) => a -> b show forall a b. (a -> b) -> a -> b $ forall err e' (r :: EffectRow) a. Member (Stop e') r => (err -> e') -> Sem (Stop err : r) a -> Sem r a mapStop @DbError @Text forall b a. (Show a, IsString b) => a -> b show forall a b. (a -> b) -> a -> b $ forall err e' (r :: EffectRow) a. Member (Stop e') r => (err -> e') -> Sem (Stop err : r) a -> Sem r a mapStop @DbConnectionError @Text forall b a. (Show a, IsString b) => a -> b show forall a b. (a -> b) -> a -> b $ DbConfig -> Sem (DbErrors ++ r) () run DbConfig conf Maybe DbConfig Nothing -> forall (f :: * -> *). Applicative f => f () unit integrationTestWith :: HasCallStack => String -> Text -> (DbConfig -> Sem TestEffects ()) -> TestT IO () integrationTestWith :: HasCallStack => String -> Text -> (DbConfig -> Sem TestEffects ()) -> TestT IO () integrationTestWith String envPrefix Text name DbConfig -> Sem TestEffects () run = forall a. HasCallStack => (HasCallStack => a) -> a withFrozenCallStack forall a b. (a -> b) -> a -> b $ forall a. HasCallStack => Sem '[Test, Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO, Resource, Final IO] a -> TestT IO a runTestAuto do Either Text () r <- forall (r :: EffectRow) a. Member (Final IO) r => Sem (Async : r) a -> Sem r a asyncToIOFinal forall a b. (a -> b) -> a -> b $ forall (r :: EffectRow). Member (Final IO) r => InterpreterFor Race r interpretRace forall a b. (a -> b) -> a -> b $ forall (r :: EffectRow). Member (Final IO) r => InterpreterFor Mask r interpretMaskFinal forall a b. (a -> b) -> a -> b $ forall e (r :: EffectRow) a. Sem (Error e : r) a -> Sem r (Either e a) runError @Text forall a b. (a -> b) -> a -> b $ forall (r :: EffectRow). Members '[Resource, Async, Race, Embed IO] r => Maybe Severity -> InterpreterFor Log r interpretLogStdoutLevelConc (forall a. a -> Maybe a Just Severity Error) forall a b. (a -> b) -> a -> b $ 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). Member (Embed IO) r => InterpreterFor GhcTime r interpretTimeGhc forall a b. (a -> b) -> a -> b $ forall (r :: EffectRow). (Members '[Error Text, Embed IO] r, HasCallStack) => String -> Text -> (DbConfig -> Sem (DbErrors ++ r) ()) -> Sem r () runIntegrationTestWith String envPrefix Text name DbConfig -> Sem TestEffects () run forall a (m :: * -> *) e (r :: EffectRow). (Show e, Monad m, HasCallStack, Member (Hedgehog m) r) => Either e a -> Sem r a Hedgehog.evalEither Either Text () r integrationTest :: HasCallStack => String -> Text -> Sem (TestConnectionEffects ++ TestEffects) () -> TestT IO () integrationTest :: HasCallStack => String -> Text -> Sem (TestConnectionEffects ++ TestEffects) () -> TestT IO () integrationTest String envPrefix Text name Sem (TestConnectionEffects ++ TestEffects) () thunk = forall a. HasCallStack => (HasCallStack => a) -> a withFrozenCallStack do HasCallStack => String -> Text -> (DbConfig -> Sem TestEffects ()) -> TestT IO () integrationTestWith String envPrefix Text name \ DbConfig conf -> 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 conf Sem (TestConnectionEffects ++ TestEffects) () thunk