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