RunIntegration.hs

module Polysemy.Hasql.Test.RunIntegration where

import Data.UUID (UUID)
import Hasql.Session (QueryError)
import Hedgehog (TestT)
import Log (Severity (Error))
import Polysemy.Db.Data.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 Polysemy.Db.Interpreter.Random (interpretRandom)
import Time (GhcTime, interpretTimeGhc)
import Zeugma.Run (TestStack, runTestLevel)

import Polysemy.Hasql.Test.Database (TestConnectionEffects, withTestConnection)
import Polysemy.Hasql.Test.DbConfig (dbConfig)

type DbErrors =
  [
    Stop DbConnectionError,
    Stop DbError,
    Stop QueryError,
    Stop Text,
    Error InitDbError,
    Error DbError
  ]

type TestEffects =
  DbErrors ++ [
    GhcTime,
    Random UUID
  ] ++ TestStack

runIntegrationTestWith ::
  Members [Error Text, Embed IO] r =>
  HasCallStack =>
  (DbConfig -> Sem (DbErrors ++ r) ()) ->
  Sem r ()
runIntegrationTestWith run =
  withFrozenCallStack do
    dbConfig >>= \case
      Just conf ->
        mapError @DbError @Text show $
        mapError @InitDbError @Text show $
        stopToError @Text $
        mapStop @QueryError @Text show $
        mapStop @DbError @Text show $
        mapStop @DbConnectionError @Text show $
        run conf
      Nothing ->
        unit

integrationTestLevelWith ::
  HasCallStack =>
  Severity ->
  (DbConfig -> Sem TestEffects ()) ->
  TestT IO ()
integrationTestLevelWith level run =
  withFrozenCallStack $ runTestLevel level $ interpretRandom $ interpretTimeGhc $ runIntegrationTestWith run

integrationTestWith ::
  HasCallStack =>
  (DbConfig -> Sem TestEffects ()) ->
  TestT IO ()
integrationTestWith =
  integrationTestLevelWith Error

integrationTestLevel ::
  HasCallStack =>
  Severity ->
  Sem (TestConnectionEffects ++ TestEffects) () ->
  TestT IO ()
integrationTestLevel level thunk =
  withFrozenCallStack do
    integrationTestLevelWith level \ conf -> withTestConnection conf thunk

integrationTest ::
  HasCallStack =>
  Sem (TestConnectionEffects ++ TestEffects) () ->
  TestT IO ()
integrationTest =
  integrationTestLevel Error