hpqtypes-1.15.0.0: test/Main.hs

{-# OPTIONS_GHC -Wno-deprecations -Wno-orphans #-}

module Main (main) where

import Control.Concurrent.Lifted
import Control.Exception qualified as E
import Control.Monad
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.State qualified as S
import Control.Monad.Trans.Control
import Data.Aeson hiding ((<?>))
import Data.ByteString qualified as BS
import Data.Char
import Data.Function
import Data.Int
import Data.List qualified as L
import Data.Maybe
import Data.Text qualified as T
import Data.Time
import Data.Typeable
import Data.UUID.Types qualified as U
import Data.Word
import System.Environment
import System.Exit
import System.Random
import System.Timeout.Lifted
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test, assertEqual)
import Test.QuickCheck
import Test.QuickCheck.Gen
import Test.QuickCheck.Random
import TextShow

import Data.Monoid.Utils
import Database.PostgreSQL.PQTypes
import Prelude.Instances ()
import Test.Aeson.Compat (Value0)
import Test.QuickCheck.Arbitrary.Instances

type InnerTestEnv = S.StateT QCGen (DBT IO)

newtype TestEnv a = TestEnv {unTestEnv :: InnerTestEnv a}
  deriving
    ( Applicative
    , Functor
    , Monad
    , MonadFail
    , MonadBase IO
    , MonadCatch
    , MonadDB
    , MonadMask
    , MonadThrow
    )

instance MonadBaseControl IO TestEnv where
  type StM TestEnv a = StM InnerTestEnv a
  liftBaseWith f = TestEnv $ liftBaseWith (\run -> f $ run . unTestEnv)
  restoreM = TestEnv . restoreM

withQCGen :: (QCGen -> r) -> TestEnv r
withQCGen f = do
  gen <- TestEnv $ S.state split
  pure (f gen)

----------------------------------------

type TestData = (QCGen, ConnectionSettings)

runTestEnv :: TestData -> TransactionSettings -> TestEnv a -> IO a
runTestEnv (env, connSettings) ts m = runDBT cs ts $ S.evalStateT (unTestEnv m) env
  where
    ConnectionSource cs = simpleSource connSettings

runTimes :: Monad m => Int -> m () -> m ()
runTimes !n m = case n of
  0 -> pure ()
  _ -> m >> runTimes (n - 1) m

----------------------------------------

newtype AsciiChar = AsciiChar {unAsciiChar :: Char}
  deriving (Eq, Show)

instance PQFormat AsciiChar where
  pqFormat = pqFormat @Char

instance ToSQL AsciiChar where
  type PQDest AsciiChar = PQDest Char
  toSQL = toSQL . unAsciiChar

instance FromSQL AsciiChar where
  type PQBase AsciiChar = PQBase Char
  fromSQL = fmap AsciiChar . fromSQL

instance Arbitrary AsciiChar where
  -- QuickCheck >= 2.10 changed Arbitrary Char instance to include proper
  -- Unicode CharS, but PostgreSQL only accepts ASCII ones.
  arbitrary = AsciiChar . chr <$> oneof [choose (0, 127), choose (0, 255)]
  shrink = map AsciiChar . shrink . unAsciiChar

instance Arbitrary Interval where
  arbitrary =
    Interval
      <$> abs `fmap` arbitrary
      <*> choose (0, 11)
      <*> choose (0, 364)
      <*> choose (0, 23)
      <*> choose (0, 59)
      <*> choose (0, 59)
      <*> choose (0, 999999)

instance (Arbitrary a1, Arbitrary a2) => Arbitrary (a1 :*: a2) where
  arbitrary = (:*:) <$> arbitrary <*> arbitrary

instance Arbitrary a => Arbitrary (Composite a) where
  arbitrary = Composite <$> arbitrary

instance Arbitrary json => Arbitrary (JSON json) where
  arbitrary = JSON <$> arbitrary

instance Arbitrary jsonb => Arbitrary (JSONB jsonb) where
  arbitrary = JSONB <$> arbitrary

instance Arbitrary a => Arbitrary (Array1 a) where
  arbitrary = arbitraryArray1 Array1

instance Arbitrary a => Arbitrary (CompositeArray1 a) where
  arbitrary = arbitraryArray1 CompositeArray1

instance Arbitrary a => Arbitrary (Array2 a) where
  arbitrary = arbitraryArray2 Array2

instance Arbitrary a => Arbitrary (CompositeArray2 a) where
  arbitrary = arbitraryArray2 CompositeArray2

arbitraryArray1 :: Arbitrary a => (a -> b) -> Gen b
arbitraryArray1 arr1 = arr1 <$> arbitrary

arbitraryArray2 :: Arbitrary a => ([[a]] -> b) -> Gen b
arbitraryArray2 arr2 = do
  let bound = (`mod` 100) . abs
  outerDim <- bound <$> arbitrary
  innerDim <- bound <$> arbitrary
  arr2 <$> vectorOf outerDim (vectorOf innerDim arbitrary)

----------------------------------------

data Simple = Simple (Maybe Int32) (Maybe Day)
  deriving (Eq, Ord, Show)

type instance CompositeRow Simple = (Maybe Int32, Maybe Day)

instance PQFormat Simple where
  pqFormat = "%simple_"
instance CompositeFromSQL Simple where
  toComposite (a, b) = Simple a b
instance CompositeToSQL Simple where
  fromComposite (Simple a b) = (a, b)

instance Arbitrary Simple where
  arbitrary = Simple <$> arbitrary <*> arbitrary

data Nested = Nested (Maybe Double) (Maybe Simple)
  deriving (Eq, Ord, Show)

type instance CompositeRow Nested = (Maybe Double, Maybe (Composite Simple))

instance PQFormat Nested where
  pqFormat = "%nested_"
instance CompositeFromSQL Nested where
  toComposite (a, b) = Nested a (unComposite <$> b)
instance CompositeToSQL Nested where
  fromComposite (Nested a b) = (a, Composite <$> b)

instance Arbitrary Nested where
  arbitrary = Nested <$> arbitrary <*> arbitrary

----------------------------------------

epsilon :: Fractional a => a
epsilon = 0.00001

eqTOD :: TimeOfDay -> TimeOfDay -> Bool
eqTOD a b =
  (todHour a == todHour b)
    && (todMin a == todMin b)
    && (abs (todSec a - todSec b) < epsilon)

eqLT :: LocalTime -> LocalTime -> Bool
eqLT a b =
  (localDay a == localDay b)
    && (localTimeOfDay a `eqTOD` localTimeOfDay b)

eqUTCT :: UTCTime -> UTCTime -> Bool
eqUTCT a b =
  (utctDay a == utctDay b)
    && (abs (utctDayTime a - utctDayTime b) < epsilon)

eqArray2 :: Eq a => Array2 a -> Array2 a -> Bool
eqArray2 (Array2 []) (Array2 arr) = all null arr
eqArray2 (Array2 arr) (Array2 []) = all null arr
eqArray2 a b = a == b

eqCompositeArray2 :: Eq a => CompositeArray2 a -> CompositeArray2 a -> Bool
eqCompositeArray2 (CompositeArray2 []) (CompositeArray2 arr) = all null arr
eqCompositeArray2 (CompositeArray2 arr) (CompositeArray2 []) = all null arr
eqCompositeArray2 a b = a == b

----------------------------------------

randomValue :: Arbitrary t => Int -> TestEnv t
randomValue n = withQCGen $ \gen -> unGen arbitrary gen n

assertEqual
  :: (Show a, MonadBase IO m)
  => String
  -> a
  -> a
  -> (a -> a -> Bool)
  -> m ()
assertEqual preface expected actual eq =
  liftBase $ unless (actual `eq` expected) (assertFailure msg)
  where
    msg =
      (if null preface then "" else preface ++ "\n") ++ ("expected: " ++ show expected ++ "\n but got: " ++ show actual)

assertEqualEq :: (Eq a, Show a, MonadBase IO m) => String -> a -> a -> m ()
assertEqualEq preface expected actual = assertEqual preface expected actual (==)

----------------------------------------

sqlGenInts :: Int32 -> SQL
sqlGenInts n =
  smconcat
    [ "WITH RECURSIVE ints(n) AS"
    , "( VALUES (1) UNION ALL SELECT n+1 FROM ints WHERE n <" <?> n
    , ") SELECT n FROM ints"
    ]

cursorTest :: TestData -> Test
cursorTest td =
  testGroup
    "Cursors"
    [ basicCursorWorks
    , scrollableCursorWorks
    , withHoldCursorWorks
    , doubleCloseWorks
    , cleanupDoesNotMaskErrors
    ]
  where
    basicCursorWorks = testCase "Basic cursor works" $ do
      runTestEnv td defaultTransactionSettings $ do
        withCursor "ints" NoScroll NoHold (sqlGenInts 5) $ \cursor -> do
          xs <- (`fix` []) $ \loop acc ->
            cursorFetch cursor CD_Next >>= \case
              0 -> pure $ reverse acc
              1 -> do
                (n :: Int32) <- fetchOne runIdentity
                loop $ n : acc
              n -> error $ "Unexpected number of rows: " ++ show n
          assertEqualEq "Data fetched correctly" [1 .. 5] xs

    scrollableCursorWorks = testCase "Cursor declared as SCROLL works" $ do
      runTestEnv td defaultTransactionSettings $ do
        withCursor "ints" Scroll NoHold (sqlGenInts 10) $ \cursor -> do
          checkMove cursor CD_Next 1
          checkMove cursor CD_Prior 0
          checkMove cursor CD_First 1
          checkMove cursor CD_Last 1
          checkMove cursor CD_Backward_All 9
          checkMove cursor CD_Forward_All 10
          checkMove cursor (CD_Absolute 0) 0
          checkMove cursor (CD_Relative 0) 0
          checkMove cursor (CD_Forward 5) 5
          checkMove cursor (CD_Backward 5) 4

          cursorFetch_ cursor CD_Forward_All
          xs1 :: [Int32] <- fetchMany runIdentity
          assertEqualEq "xs1 is correct" [1 .. 10] xs1
          cursorFetch_ cursor CD_Backward_All
          xs2 :: [Int32] <- fetchMany runIdentity
          assertEqualEq "xs2 is correct" (reverse [1 .. 10]) xs2
      where
        checkMove cursor cd expected = do
          moved <- cursorMove cursor cd
          assertEqualEq
            ( "Moving cursor with"
                <+> show cd
                <+> "would fetch a correct amount of rows"
            )
            expected
            moved

    withHoldCursorWorks = testCase "Cursor declared as WITH HOLD works" $ do
      runTestEnv td defaultTransactionSettings . unsafeWithoutTransaction $ do
        withCursor "ints" NoScroll Hold (sqlGenInts 10) $ \cursor -> do
          cursorFetch_ cursor CD_Forward_All
          sum_ :: Int32 <- sum . fmap runIdentity <$> queryResult
          assertEqualEq "sum_ is correct" 55 sum_

    doubleCloseWorks = testCase "Double CLOSE works on a cursor" $ do
      runTestEnv td defaultTransactionSettings $ do
        withCursorSQL "ints" NoScroll NoHold "SELECT 1" $ \_cursor -> do
          -- Commiting a transaction closes the cursor
          commit

    cleanupDoesNotMaskErrors = testCase "Cursor cleanup doesn't mask the original error" $ do
      runTestEnv td defaultTransactionSettings $ do
        -- The failing query puts the transaction in the aborted state, in
        -- which closing the cursor fails with in_failed_sql_transaction. The
        -- original error needs to propagate regardless.
        eres <- try . withCursorSQL "ints" NoScroll NoHold (sqlGenInts 5) $ \_cursor -> do
          runSQL_ "SELECT 1/0"
        liftBase $ case eres :: Either DBException () of
          Left DBException {..}
            | Just DetailedQueryError {..} <- cast dbeError -> do
                assertEqualEq "Unexpected error code" DivisionByZero qeErrorCode
            | otherwise -> assertFailure $ "Unexpected exception: " ++ show dbeError
          Right () -> assertFailure "DBException wasn't thrown"

queryInterruptionTest :: TestData -> Test
queryInterruptionTest td = testCase "Queries are interruptible" $ do
  let sleep = "SELECT pg_sleep(2)"
      ints = sqlGenInts 5000000
  runTestEnv td defaultTransactionSettings . unsafeWithoutTransaction $ do
    testQuery id sleep
    testQuery id ints
  runTestEnv td defaultTransactionSettings $ do
    testQuery (withSavepoint "ints") ints
    testQuery (withSavepoint "sleep") sleep
  where
    testQuery m sql =
      timeout 500000 (m $ runSQL_ sql) >>= \case
        Just _ -> liftBase $ do
          assertFailure $ "Query" <+> show sql <+> "wasn't interrupted in time"
        Nothing -> pure ()

autocommitTest :: TestData -> Test
autocommitTest td = testCase "Autocommit mode works"
  . runTestEnv td defaultTransactionSettings
  . unsafeWithoutTransaction
  $ do
    let sint = Identity (1 :: Int32)
    runQuery_ $ rawSQL "INSERT INTO test1_ (a) VALUES ($1)" sint
    withNewSession $ do
      n <- runQuery $ rawSQL "SELECT a FROM test1_ WHERE a = $1" sint
      assertEqualEq "Other connection sees autocommited data" 1 n
    runQuery_ $ rawSQL "DELETE FROM test1_ WHERE a = $1" sint

setRoleTest :: TestData -> Test
setRoleTest td = testCase "SET ROLE works" . bracket createRole dropRole $ \case
  False -> putStrLn "Cannot create role, skipping SET ROLE test"
  True -> do
    runDBT roledCs defaultTransactionSettings $ do
      runSQL_ "SELECT CURRENT_USER::text"
      role <- fetchOne (runIdentity @String)
      assertEqualEq "Role set successfully" testRole role
  where
    testRole :: String
    testRole = "hpqtypes_test_role"

    ConnectionSource roledCs =
      simpleSource $
        (snd td)
          { csRole = Just $ unsafeSQL testRole
          }

    createRole = runTestEnv td defaultTransactionSettings $ do
      try (runSQL_ $ "CREATE ROLE" <+> unsafeSQL testRole) >>= \case
        Right () -> pure True
        Left DBException {} -> pure False

    dropRole = \case
      False -> pure ()
      True -> runTestEnv td defaultTransactionSettings $ do
        runSQL_ $ "DROP ROLE" <+> unsafeSQL testRole

preparedStatementTest :: TestData -> Test
preparedStatementTest td = testCase "Execution of prepared statements works"
  . runTestEnv td defaultTransactionSettings
  $ do
    let name = "select1"

    checkPrepared name "Statement is not prepared" 0
    execPrepared name 42
    checkPrepared name "Statement is prepared" 1
    execPrepared name 89

    let i3 = "lalala" :: String
    -- Changing parameter type in an already prepared statement shouldn't work.
    o3 <- try . runPreparedQuery_ name $ ("SELECT" <?> i3)
    case o3 of
      Left DBException {} -> pure ()
      Right r3 -> liftBase . assertFailure $ "Expected DBException, but got" <+> show r3
  where
    checkPrepared :: QueryName -> String -> Int -> TestEnv ()
    checkPrepared (QueryName name) assertTitle expected = do
      n <- runSQL $ "SELECT TRUE FROM pg_prepared_statements WHERE name =" <?> name
      assertEqualEq assertTitle expected n

    execPrepared :: QueryName -> Int32 -> TestEnv ()
    execPrepared name input = do
      runPreparedQuery_ name $ "SELECT" <?> input
      output <- fetchOne runIdentity
      assertEqualEq "Results match" input output

readOnlyTest :: TestData -> Test
readOnlyTest td = testCase "Read only transaction mode works"
  . runTestEnv
    td
    defaultTransactionSettings {tsConnectionAcquisitionMode = AcquireAndHold DefaultLevel ReadOnly}
  $ do
    let sint = Identity (2 :: Int32)
    eres <- try . runQuery_ $ rawSQL "INSERT INTO test1_ (a) VALUES ($1)" sint
    case eres :: Either DBException () of
      Left _ -> pure ()
      Right _ -> liftBase . assertFailure $ "DBException wasn't thrown"
    rollback
    n <- runQuery $ rawSQL "SELECT a FROM test1_ WHERE a = $1" sint
    assertEqualEq "SELECT works in read only mode" 0 n

savepointTest :: TestData -> Test
savepointTest td = testCase "Savepoint support works"
  . runTestEnv td defaultTransactionSettings
  $ do
    let int1 = 3 :: Int32
        int2 = 4 :: Int32

    -- action executed within withSavepoint throws
    runQuery_ $ rawSQL "INSERT INTO test1_ (a) VALUES ($1)" (Identity int1)
    _ :: Either DBException () <- try . withSavepoint (Savepoint "test") $ do
      runQuery_ $ rawSQL "INSERT INTO test1_ (a) VALUES ($1)" (Identity int2)
      runSQL_ "SELECT * FROM table_that_is_not_there"
    runQuery_ $ rawSQL "SELECT a FROM test1_ WHERE a IN ($1, $2)" (int1, int2)
    res1 <- fetchMany runIdentity
    assertEqualEq "Part of transaction was rolled back" [int1] res1

    rollback

    -- action executed within withSavepoint doesn't throw
    runQuery_ $ rawSQL "INSERT INTO test1_ (a) VALUES ($1)" (Identity int1)
    withSavepoint (Savepoint "test") $ do
      runQuery_ $ rawSQL "INSERT INTO test1_ (a) VALUES ($1)" (Identity int2)
    runQuery_ $
      rawSQL
        "SELECT a FROM test1_ WHERE a IN ($1, $2) ORDER BY a"
        (int1, int2)
    res2 <- fetchMany runIdentity
    assertEqualEq "Result of all queries is visible" [int1, int2] res2

savepointDeadConnectionTest :: TestData -> Test
savepointDeadConnectionTest td = testCase
  "Failed savepoint cleanup doesn't mask the error of the action"
  $ do
    -- The action kills its own backend. The savepoint cleanup fails as well,
    -- because the connection is gone. The error of the action must propagate
    -- regardless.
    eres <- try . runTestEnv td defaultTransactionSettings . withSavepoint "test" $ do
      runSQL_ "SELECT pg_terminate_backend(pg_backend_pid())"
    case eres of
      Left DBException {..} ->
        assertBool ("Exception comes from the action: " ++ show dbeQueryContext) $
          "pg_terminate_backend" `L.isInfixOf` show dbeQueryContext
      Right () -> assertFailure "DBException wasn't thrown"

withoutTransactionDeadConnectionTest :: TestData -> Test
withoutTransactionDeadConnectionTest td = testCase
  "Failed BEGIN after unsafeWithoutTransaction doesn't mask the error of the action"
  $ do
    -- The action kills its own backend. The BEGIN that restores the
    -- transaction fails as well, because the connection is gone. The error of
    -- the action must propagate regardless.
    eres <- try . runTestEnv td defaultTransactionSettings . unsafeWithoutTransaction $ do
      runSQL_ "SELECT pg_terminate_backend(pg_backend_pid())"
    case eres of
      Left DBException {..} ->
        assertBool ("Exception comes from the action: " ++ show dbeQueryContext) $
          "pg_terminate_backend" `L.isInfixOf` show dbeQueryContext
      Right () -> assertFailure "DBException wasn't thrown"

notifyTest :: TestData -> Test
notifyTest td = testCase "Notifications work" . runTestEnv td defaultTransactionSettings . unsafeWithoutTransaction $ do
  listen chan
  forkNewSession $ notify chan payload
  mnt1 <- getNotification 250000
  liftBase $ assertBool "Notification received" (isJust mnt1)
  Just nt1 <- pure mnt1
  assertEqualEq "Channels are equal" chan (ntChannel nt1)
  assertEqualEq "Payloads are equal" payload (ntPayload nt1)

  unlisten chan
  forkNewSession $ notify chan payload
  mnt2 <- getNotification 250000
  assertEqualEq "No notification received after unlisten" Nothing mnt2

  listen chan
  unlistenAll
  forkNewSession $ notify chan payload
  mnt3 <- getNotification 250000
  assertEqualEq "No notification received after unlistenAll" Nothing mnt3
  where
    chan = "test_channel"
    payload = "test_payload"
    forkNewSession = void . fork . withNewSession

transactionTest :: TestData -> IsolationLevel -> Test
transactionTest td lvl =
  testCase
    ( "Auto transaction works by default with isolation level"
        <+> show lvl
    )
    . runTestEnv
      td
      defaultTransactionSettings {tsConnectionAcquisitionMode = AcquireAndHold lvl DefaultPermissions}
    $ do
      let sint = Identity (5 :: Int32)
      runQuery_ $ rawSQL "INSERT INTO test1_ (a) VALUES ($1)" sint
      withNewSession $ do
        n <- runQuery $ rawSQL "SELECT a FROM test1_ WHERE a = $1" sint
        assertEqualEq "Other connection doesn't see uncommited data" 0 n
      rollback

nullTest
  :: forall t
   . (Show t, ToSQL t, FromSQL t, Typeable t)
  => TestData
  -> t
  -> Test
nullTest td t = testCase
  ( "Attempt to get non-NULL value of type"
      <+> show (typeOf t)
      <+> "fails if NULL is provided"
  )
  . runTestEnv td defaultTransactionSettings
  $ do
    runSQL_ $ "SELECT" <?> (Nothing :: Maybe t)
    eres <- try $ fetchOne runIdentity
    case eres :: Either DBException t of
      Left _ -> pure ()
      Right _ -> liftBase . assertFailure $ "DBException wasn't thrown"

putGetTest
  :: forall t
   . (Arbitrary t, Show t, ToSQL t, FromSQL t, Typeable t)
  => TestData
  -> Int
  -> t
  -> (t -> t -> Bool)
  -> Test
putGetTest td n t eq = testCase
  ( "Putting value of type"
      <+> show (typeOf t)
      <+> "through database doesn't change its value"
  )
  . runTestEnv td defaultTransactionSettings
  . runTimes 1000
  $ do
    v :: t <- randomValue n
    -- liftBase . putStrLn . show $ v
    runSQL_ $ "SELECT" <?> v
    v' <- fetchOne runIdentity
    assertEqual "Value doesn't change after getting through database" v v' eq

uuidTest :: TestData -> Test
uuidTest td = testCase "UUID encoding / decoding test" $ do
  let uuidStr = "550e8400-e29b-41d4-a716-446655440000"
  Just uuid <- pure $ U.fromText uuidStr
  runTestEnv td defaultTransactionSettings $ do
    runSQL_ . mkSQL $ ("SELECT '" `mappend` uuidStr `mappend` "' :: uuid")
    uuid2 <- fetchOne runIdentity
    assertEqual "UUID is decoded correctly" uuid uuid2 (==)

    runQuery_ $ rawSQL " SELECT $1 :: text" (Identity uuid)
    uuidStr2 <- fetchOne runIdentity
    assertEqual "UUID is encoded correctly" uuidStr uuidStr2 (==)

integerTest :: TestData -> Test
integerTest td = testCase "Integer decoding from numeric works"
  . runTestEnv td defaultTransactionSettings
  . forM_ values
  $ \n -> do
    -- The server strips trailing zero base-10000 digit groups from the wire
    -- representation of numeric, so values that are multiples of 10000 arrive
    -- with fewer digits than their weight indicates.
    runSQL_ . mkSQL $ "SELECT " <> showt n <> " :: numeric"
    n' <- fetchOne runIdentity
    assertEqualEq ("Integer" <+> show n <+> "is decoded correctly") n n'

    runQuery_ $ rawSQL "SELECT $1" (Identity n)
    n'' <- fetchOne runIdentity
    assertEqualEq ("Integer" <+> show n <+> "roundtrips correctly") n n''
  where
    values :: [Integer]
    values =
      [ 0
      , 1
      , -1
      , 9999
      , 10000
      , -10000
      , 10001
      , 99990000
      , 100000000
      , 1000000000000
      , -1000000000000
      , 123400005678
      , 10 ^ (100 :: Int)
      , negate $ 10 ^ (100 :: Int)
      , 10 ^ (100 :: Int) + 1
      ]

jsonTest :: TestData -> Test
jsonTest td = testCase "JSON conversion failures and raw values"
  . runTestEnv td defaultTransactionSettings
  $ do
    -- If the FromJSON instance of the target type rejects a value, decoding
    -- fails with the error of the instance.
    runSQL_ "SELECT '\"str\"'::json"
    expectAesonError "json as Int64" . void $
      fetchOne (runIdentity @(JSON Int64))
    runSQL_ "SELECT '\"str\"'::jsonb"
    expectAesonError "jsonb as Int64" . void $
      fetchOne (runIdentity @(JSONB Int64))

    -- A raw value arrives as the text of the value. The server stores it
    -- verbatim for json and normalizes it for jsonb.
    runSQL_ "SELECT '{\"b\": 1,  \"a\": 2}'::json, '{\"b\": 1,  \"a\": 2}'::jsonb"
    (rawJson, rawJsonb) <- fetchOne id
    assertEqualEq "json text is verbatim" (RawJSON "{\"b\": 1,  \"a\": 2}") rawJson
    assertEqualEq "jsonb text is normalized" (RawJSONB "{\"a\": 2, \"b\": 1}") rawJsonb
  where
    -- The error of the FromJSON instance arrives inside a ConversionError.
    expectAesonError :: String -> TestEnv () -> TestEnv ()
    expectAesonError preface action =
      try action >>= \case
        Left (err :: DBException) ->
          liftBase . assertBool (preface <> ": " <> show err) $
            "expected Number, but encountered String" `L.isInfixOf` show err
        Right () -> liftBase . assertFailure $ preface <> ": no error was thrown"

restartTest :: TestData -> Test
restartTest td =
  testGroup
    "Transaction restarts"
    [ restartedTransactionIsNotMasked
    , asyncExceptionsDontTriggerRestarts
    ]
  where
    restartedTransactionIsNotMasked = testCase
      "Restarted transaction doesn't run with asynchronous exceptions masked"
      $ do
        let ts =
              defaultTransactionSettings
                { tsRestartPredicate = Just . RestartPredicate $ \(e :: E.ErrorCall) _ ->
                    e == E.ErrorCall "restart"
                }
        attempts <- newMVar (0 :: Int)
        runTestEnv td ts $ do
          n <- modifyMVar attempts $ \n -> pure (n + 1, n + 1)
          when (n == 1) . throwM $ E.ErrorCall "restart"
          ms <- liftBase E.getMaskingState
          assertEqualEq "Unexpected masking state" E.Unmasked ms

    asyncExceptionsDontTriggerRestarts = testCase
      "Asynchronous exceptions don't trigger a transaction restart"
      $ do
        let ts =
              defaultTransactionSettings
                { tsRestartPredicate = Just . RestartPredicate $ \(_ :: SomeException) n ->
                    n < 3
                }
        timeout 500000 (runTestEnv td ts $ runSQL_ "SELECT pg_sleep(2)") >>= \case
          Just _ -> assertFailure "Query wasn't interrupted in time"
          Nothing -> pure ()

copyNotSupportedTest :: TestData -> Test
copyNotSupportedTest td = testCase "COPY statements fail with an error"
  . runTestEnv td defaultTransactionSettings
  $ do
    eres <- try $ runSQL_ "COPY (SELECT 1) TO STDOUT"
    case eres of
      Left DBException {dbeError = err} -> case fromException $ toException err of
        Just (HPQTypesError msg) ->
          liftBase . assertBool ("Error message mentions COPY: " ++ msg) $
            "COPY" `L.isInfixOf` msg
        Nothing -> liftBase . assertFailure $ "Unexpected error: " ++ show err
      Right () -> liftBase $ assertFailure "COPY statement didn't fail"
    -- libpq ends the copy mode when the next query runs, so the connection
    -- stays usable.
    runSQL_ "SELECT 1"
    n <- fetchOne (runIdentity @Int32)
    assertEqualEq "Connection is usable after the failed COPY" 1 n

xmlTest :: TestData -> Test
xmlTest td = testCase "Put and get XML value works"
  . runTestEnv td defaultTransactionSettings
  $ do
    runSQL_ "SET CLIENT_ENCODING TO 'UTF8'"
    let v = XML "some<tag>stringå</tag>"
    runSQL_ "SELECT XML 'some<tag>stringå</tag>'"
    v' <- fetchOne runIdentity
    assertEqualEq "XML value correct" v v'
    runSQL_ $ "SELECT" <?> v
    v'' <- fetchOne runIdentity
    assertEqualEq "XML value correct" v v''
    runSQL_ "SET CLIENT_ENCODING TO 'latin-1'"

onDemandDeadConnectionTest :: TestData -> Test
onDemandDeadConnectionTest td = testCase
  "Failed ROLLBACK of an on demand transaction doesn't mask the query error"
  . runTestEnv td ts
  $ do
    -- The query kills its own backend. The ROLLBACK that ends the automatic
    -- transaction fails as well, because the connection is gone. The error of
    -- the query must propagate regardless.
    eres <- try $ runSQL_ "SELECT pg_terminate_backend(pg_backend_pid())"
    liftBase $ case eres of
      Left DBException {..} ->
        assertBool ("Exception comes from the query: " ++ show dbeQueryContext) $
          "pg_terminate_backend" `L.isInfixOf` show dbeQueryContext
      Right () -> assertFailure "DBException wasn't thrown"
  where
    ts = defaultTransactionSettings {tsConnectionAcquisitionMode = AcquireOnDemand}

onDemandTest :: TestData -> Test
onDemandTest td = testCase "OnDemand mode works" . runTestEnv td ts $ do
  runSQL_ "SELECT a FROM test1_"
  _ <- fetchMany $ id @(Identity Int32)

  er <- try . runSQL_ $ "INSERT INTO test1_ (a) VALUES (" <?> v <+> ")"
  liftBase $ case er of
    Left DBException {..}
      | Just DetailedQueryError {..} <- cast dbeError -> do
          assertEqualEq "Unexpected error code" ReadOnlySqlTransaction qeErrorCode
      | otherwise -> assertFailure $ "Unexpected exception: " ++ show dbeError
    Right () -> assertFailure "DBException wasn't thrown"

  acquireAndHoldConnection DefaultLevel DefaultPermissions
  runSQL_ "SHOW transaction_read_only"
  Identity ("off" :: T.Text) <- fetchOne id
  -- Switch twice to check idempotency.
  acquireAndHoldConnection DefaultLevel DefaultPermissions
  runSQL_ $ "INSERT INTO test1_ (a) VALUES (" <?> v <+> ")"

  unsafeAcquireOnDemandConnection
  runSQL_ "SHOW transaction_read_only"
  Identity ("on" :: T.Text) <- fetchOne id
  -- Switch twice to check idempotency.
  unsafeAcquireOnDemandConnection
  n <- runSQL $ "SELECT TRUE FROM test1_ WHERE a =" <?> v
  assertEqualEq "Unexpected amount of rows" 1 n
  where
    ts = defaultTransactionSettings {tsConnectionAcquisitionMode = AcquireOnDemand}

    v :: Int32
    v = 1337

sessionOwnerTest :: TestData -> Test
sessionOwnerTest td =
  testCase "Only the thread that owns a DB session can use it"
    . runTestEnv td defaultTransactionSettings
    $ do
      result <- newEmptyMVar
      _ <- fork $ do
        sameSessionQuery <- try $ runSQL_ "SELECT 1"
        sameSessionModeChange <- try unsafeAcquireOnDemandConnection
        newSession <- try . withNewSession $ runSQL_ "SELECT 1"
        putMVar result (sameSessionQuery, sameSessionModeChange, newSession)
      (sameSessionQuery, sameSessionModeChange, newSession) <- takeMVar result
      liftBase $ do
        assertThreadMismatch "runSQL_" sameSessionQuery
        assertThreadMismatch "unsafeAcquireOnDemandConnection" sameSessionModeChange
        case newSession of
          Left (e :: SomeException) ->
            assertFailure $ "withNewSession failed in another thread: " ++ show e
          Right () -> pure ()
  where
    assertThreadMismatch :: String -> Either SomeException () -> Assertion
    assertThreadMismatch op = \case
      Left e
        | Just DBException {..} <- fromException e
        , Just ThreadMismatchError {} <- cast dbeError ->
            pure ()
        | otherwise -> assertFailure $ op ++ " threw an unexpected exception: " ++ show e
      Right () -> assertFailure $ op ++ " didn't throw ThreadMismatchError"

childSessionTest :: TestData -> Test
childSessionTest td = testCase
  "Child thread can start a session after the parent session ended"
  $ do
    parentEnded <- newEmptyMVar
    result <- newEmptyMVar
    runTestEnv td defaultTransactionSettings $ do
      void . fork $ do
        takeMVar parentEnded
        putMVar result =<< try (withNewSession $ runSQL_ "SELECT 1")
    putMVar parentEnded ()
    takeMVar result >>= \case
      Left (e :: SomeException) ->
        assertFailure $ "withNewSession failed in the child thread: " ++ show e
      Right () -> pure ()

commitFailureTest :: TestData -> Test
commitFailureTest td = testCase
  "Transaction is active after a failed commit"
  . runTestEnv td defaultTransactionSettings
  $ do
    runSQL_ "CREATE TABLE commit_failure_ (a INTEGER UNIQUE DEFERRABLE INITIALLY DEFERRED)"
    commit
    (`finally` cleanup) $ do
      -- Deferred constraint violation makes the COMMIT fail.
      runSQL_ "INSERT INTO commit_failure_ (a) VALUES (1), (1)"
      eres <- try commit
      liftBase $ case eres :: Either DBException () of
        Left DBException {..}
          | Just DetailedQueryError {..} <- cast dbeError -> do
              assertEqualEq "Unexpected error code" UniqueViolation qeErrorCode
          | otherwise -> assertFailure $ "Unexpected exception: " ++ show dbeError
        Right () -> assertFailure "DBException wasn't thrown"
      -- A new transaction needs to be active at this point, so a write made
      -- after the failed commit must be reverted by a rollback.
      runSQL_ "INSERT INTO commit_failure_ (a) VALUES (2)"
      rollback
      n <- runSQL "SELECT a FROM commit_failure_"
      assertEqualEq "Unexpected number of rows" 0 n
  where
    cleanup = do
      rollback
      runSQL_ "DROP TABLE commit_failure_"
      commit

acquisitionModeChangeFailureTest :: TestData -> Test
acquisitionModeChangeFailureTest td = testCase
  "Connection state is usable after a failed acquisition mode change"
  . runTestEnv td defaultTransactionSettings
  $ do
    -- Violate a deferred constraint so that the COMMIT issued by
    -- unsafeAcquireOnDemandConnection fails.
    runSQL_ "CREATE TABLE mode_change_ (a INTEGER UNIQUE DEFERRABLE INITIALLY DEFERRED)"
    runSQL_ "INSERT INTO mode_change_ (a) VALUES (1), (1)"
    eres <- try unsafeAcquireOnDemandConnection
    liftBase $ case eres of
      Left DBException {..}
        | Just DetailedQueryError {..} <- cast dbeError -> do
            assertEqualEq "Unexpected error code" UniqueViolation qeErrorCode
        | otherwise -> assertFailure $ "Unexpected exception: " ++ show dbeError
      Right () -> assertFailure "DBException wasn't thrown"

    -- The failed COMMIT returned the connection to its source, so the
    -- connection state needs to be on demand now. In particular, it must not
    -- refer to the connection that is already gone.
    mode <- getConnectionAcquisitionMode
    assertEqualEq "Unexpected connection acquisition mode" AcquireOnDemand mode
    runSQL_ "SELECT 1"
    n <- fetchOne $ runIdentity @Int32
    assertEqualEq "Unexpected query result" 1 n

rowTest
  :: forall row
   . (Arbitrary row, Eq row, Show row, ToRow row, FromRow row)
  => TestData
  -> row
  -> Test
rowTest td _r = testCase
  ( "Putting row of length"
      <+> show (pqVariables @row)
      <+> "through database works"
  )
  . runTestEnv td defaultTransactionSettings
  . runTimes 100
  $ do
    row :: row <- randomValue 100
    let fmt = mintercalate ", " $ map (T.append "$" . showt) [1 .. pqVariables @row]
    runQuery_ $ rawSQL ("SELECT" <+> fmt) row
    row' <- fetchOne id
    assertEqualEq "Row doesn't change after getting through database" row row'

_printTime :: MonadBase IO m => m a -> m a
_printTime m = do
  t <- liftBase getCurrentTime
  res <- m
  t' <- liftBase getCurrentTime
  liftBase . putStrLn $ "Time: " ++ show (diffUTCTime t' t)
  pure res

tests :: TestData -> [Test]
tests td =
  [ autocommitTest td
  , setRoleTest td
  , preparedStatementTest td
  , copyNotSupportedTest td
  , xmlTest td
  , readOnlyTest td
  , savepointTest td
  , savepointDeadConnectionTest td
  , withoutTransactionDeadConnectionTest td
  , restartTest td
  , notifyTest td
  , queryInterruptionTest td
  , cursorTest td
  , uuidTest td
  , integerTest td
  , jsonTest td
  , onDemandTest td
  , onDemandDeadConnectionTest td
  , sessionOwnerTest td
  , childSessionTest td
  , acquisitionModeChangeFailureTest td
  , commitFailureTest td
  , transactionTest td ReadCommitted
  , transactionTest td RepeatableRead
  , transactionTest td Serializable
  , nullTest td (u :: Int16)
  , nullTest td (u :: Int32)
  , nullTest td (u :: Int64)
  , nullTest td (u :: Float)
  , nullTest td (u :: Double)
  , nullTest td (u :: Bool)
  , nullTest td (u :: AsciiChar)
  , nullTest td (u :: Word8)
  , nullTest td (u :: Word16)
  , nullTest td (u :: Word32)
  , nullTest td (u :: Word64)
  , nullTest td (u :: Integer)
  , nullTest td (u :: String)
  , nullTest td (u :: BS.ByteString)
  , nullTest td (u :: T.Text)
  , nullTest td (u :: U.UUID)
  , nullTest td (u :: JSON Value)
  , nullTest td (u :: JSONB Value)
  , nullTest td (u :: RawJSON)
  , nullTest td (u :: RawJSONB)
  , nullTest td (u :: XML)
  , nullTest td (u :: Interval)
  , nullTest td (u :: Day)
  , nullTest td (u :: TimeOfDay)
  , nullTest td (u :: LocalTime)
  , nullTest td (u :: UTCTime)
  , nullTest td (u :: Array1 Int32)
  , nullTest td (u :: Array2 Double)
  , nullTest td (u :: Composite Simple)
  , nullTest td (u :: CompositeArray1 Simple)
  , nullTest td (u :: CompositeArray2 Simple)
  , putGetTest td 100 (u :: Int16) (==)
  , putGetTest td 100 (u :: Int32) (==)
  , putGetTest td 100 (u :: Int64) (==)
  , putGetTest td 10000 (u :: Float) (==)
  , putGetTest td 10000 (u :: Double) (==)
  , putGetTest td 100 (u :: Bool) (==)
  , putGetTest td 100 (u :: AsciiChar) (==)
  , putGetTest td 100 (u :: Word8) (==)
  , putGetTest td 100 (u :: Word16) (==)
  , putGetTest td 100 (u :: Word32) (==)
  , putGetTest td 100 (u :: Word64) (==)
  , putGetTest td 1000000000000 (u :: Integer) (==)
  , putGetTest td 1000 (u :: String0) (==)
  , putGetTest td 1000 (u :: BS.ByteString) (==)
  , putGetTest td 1000 (u :: T.Text) (==)
  , putGetTest td 1000 (u :: U.UUID) (==)
  , putGetTest td 50 (u :: JSON Value0) (==)
  , putGetTest td 50 (u :: JSONB Value0) (==)
  , putGetTest td 50 (u :: RawJSON) (==)
  , putGetTest td 20 (u :: Array1 (JSON Value0)) (==)
  , putGetTest td 20 (u :: Array1 (JSONB Value0)) (==)
  , putGetTest td 50 (u :: Interval) (==)
  , putGetTest td 1000000 (u :: Day) (==)
  , putGetTest td 10000 (u :: TimeOfDay) eqTOD
  , putGetTest td 500000 (u :: LocalTime) eqLT
  , putGetTest td 500000 (u :: UTCTime) eqUTCT
  , putGetTest td 1000 (u :: Array1 Int32) (==)
  , putGetTest td 1000 (u :: Array2 Double) eqArray2
  , putGetTest td 100000 (u :: Composite Simple) (==)
  , putGetTest td 1000 (u :: CompositeArray1 Simple) (==)
  , putGetTest td 1000 (u :: CompositeArray2 Simple) eqCompositeArray2
  , putGetTest td 100000 (u :: Composite Nested) (==)
  , putGetTest td 1000 (u :: CompositeArray1 Nested) (==)
  , putGetTest td 1000 (u :: CompositeArray2 Nested) eqCompositeArray2
  , rowTest td (u :: Identity Int16)
  , rowTest td (u :: Identity T.Text :*: (Double, Int16))
  , rowTest td (u :: (T.Text, Double) :*: Identity Int16)
  , rowTest td (u :: (Int16, T.Text, Int64, Double) :*: Identity Bool :*: (String0, AsciiChar))
  , rowTest td (u :: (Int16, Int32))
  , rowTest td (u :: (Int16, Int32, Int64))
  , rowTest td (u :: (Int16, Int32, Int64, Float))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString))
  , rowTest td (u :: (Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Word16, Word32, Word64, Integer, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, U.UUID))
  ]
  where
    u = undefined

----------------------------------------

createStructures :: ConnectionSourceM IO -> IO ()
createStructures cs = runDBT cs defaultTransactionSettings $ do
  liftBase . putStrLn $ "Creating structures..."
  runSQL_ "CREATE TABLE test1_ (a INTEGER)"
  runSQL_ "CREATE TYPE simple_ AS (a INTEGER, b DATE)"
  runSQL_ "CREATE TYPE nested_ AS (d DOUBLE PRECISION, s SIMPLE_)"

dropStructures :: ConnectionSourceM IO -> IO ()
dropStructures cs = runDBT cs defaultTransactionSettings $ do
  liftBase . putStrLn $ "Dropping structures..."
  runSQL_ "DROP TYPE nested_"
  runSQL_ "DROP TYPE simple_"
  runSQL_ "DROP TABLE test1_"

getConnString :: IO (T.Text, [String])
getConnString =
  getArgs >>= \case
    connString : args -> pure (T.pack connString, args)
    [] ->
      lookupEnv "GITHUB_ACTIONS" >>= \case
        Just "true" -> pure ("host=localhost user=postgres password=postgres", [])
        _ -> printUsage >> exitFailure
  where
    printUsage = do
      prog <- getProgName
      putStrLn $
        "Usage:"
          <+> prog
          <+> "<connection info string> [test-framework args]"

main :: IO ()
main = do
  (connString, args) <- getConnString
  let connSettings =
        defaultConnectionSettings
          { csConnInfo = connString
          , csClientEncoding = Just "latin1"
          }
      ConnectionSource connSource = simpleSource connSettings

  createStructures connSource
  gen <- newQCGen
  putStrLn $ "PRNG:" <+> show gen

  finally (defaultMainWithArgs (tests (gen, connSettings {csComposites = ["simple_", "nested_"]})) args) $ do
    dropStructures connSource