{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
module Squeal.PostgreSQL.Hspec
import Control.Exception
import Control.Monad
import Control.Monad.Base (liftBase)
+import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BSC
import qualified Database.Postgres.Temp as Temp
import Generics.SOP (K)
import Squeal.PostgreSQL
-import Squeal.PostgreSQL.Pool
+import System.Environment (lookupEnv)
import Test.Hspec
data TestDB a = TestDB
- { tempDB :: Temp.DB
+ { tempDB :: Maybe Temp.DB
-- ^ Handle for temporary @postgres@ process
- , pool :: Pool a
+ , pool :: Pool (K Connection a)
-- ^ Pool of 50 connections to the temporary @postgres@
+ , connectionString :: ByteString
}
-type Fixtures schema = (Pool (K Connection schema) -> IO ())
-type Actions schema a = PoolPQ schema IO a
-type SquealContext schema = TestDB (K Connection schema)
+type Fixtures db a = (Pool (K Connection db) -> IO a)
+type Actions db a = PQ db db IO a
+type FixtureContext db fix = (TestDB db, fix)
+type Migrations def from to = Path (Migration def) from to
+
+testDBEnv :: String
+testDBEnv = "TEST_DB_CONNECTION_STRING"
+
+getOrCreateConnectionString :: IO (ByteString, Maybe Temp.DB)
+getOrCreateConnectionString = do
+ hasConnectionString <- lookupEnv testDBEnv
+ maybe createTempDB (pure . (, Nothing) . BSC.pack) hasConnectionString
+
+createTempDB :: IO (ByteString, Maybe Temp.DB)
+createTempDB = do
+ tempDB <- either throwIO return =<< Temp.startAndLogToTmp []
+ let connectionString = BSC.pack (Temp.connectionString tempDB)
+ pure (connectionString, Just tempDB)
-- | Start a temporary @postgres@ process and create a pool of connections to it
setupDB
- :: AlignedList (Migration (Terminally PQ IO)) schema0 schema
- -> Fixtures schema
- -> IO (SquealContext schema)
+ :: Migratory def (IsoQ (Indexed PQ IO ()))
+ => Migrations def schema0 schema
+ -> Fixtures schema fix
+ -> IO (FixtureContext schema fix)
setupDB migration fixtures = do
- tempDB <- either throwIO return =<< Temp.startAndLogToTmp []
- let connectionString = BSC.pack (Temp.connectionString tempDB)
- putStrLn $ Temp.connectionString tempDB
+ (connectionString, tempDB) <- getOrCreateConnectionString
+ BSC.putStrLn connectionString
let singleStripe = 1
keepConnectionForOneHour = 3600
poolSizeOfFifty = 50
keepConnectionForOneHour
poolSizeOfFifty
withConnection connectionString (migrateUp migration)
- fixtures pool
- pure TestDB {..}
+ res <- fixtures pool
+ pure (TestDB {..}, res)
-- | Drop all the connections and shutdown the @postgres@ process
-teardownDB :: TestDB a -> IO ()
-teardownDB TestDB {..} = do
- destroyAllResources pool
- void $ Temp.stop tempDB
+teardownDB
+ :: Migratory def (IsoQ (Indexed PQ IO ()))
+ => Migrations def schema0 schema
+ -> TestDB a
+ -> IO ()
+teardownDB migration TestDB {..} = do
+ withConnection connectionString (migrateDown migration)
+ destroyConnectionPool pool
+ maybe (pure ()) (void . Temp.stop) tempDB
-- | Run an 'IO' action with a connection from the pool
-withPool :: TestDB (K Connection schema) -> Actions schema a -> IO a
-withPool testDB = liftBase . flip runPoolPQ (pool testDB)
+withPool :: TestDB db -> Actions db a -> IO a
+withPool testDB = liftBase . usingConnectionPool (pool testDB)
-- | Run an 'DB' transaction, using 'transactionally_'
-withDB :: Actions schema a -> TestDB (K Connection schema) -> IO a
+withDB :: Actions db a -> TestDB db -> IO a
withDB action testDB =
- runPoolPQ (transactionally_ action) (pool testDB)
+ usingConnectionPool (pool testDB) (transactionally_ action)
-- | Flipped version of 'withDB'
-runDB :: TestDB (K Connection schema) -> Actions schema a -> IO a
+runDB :: TestDB db -> Actions db a -> IO a
runDB = flip withDB
+withFixture :: (fix -> Actions db a) -> FixtureContext db fix -> IO a
+withFixture action (db, fix) =
+ usingConnectionPool (pool db) (transactionally_ $ action fix)
+
+withoutFixture :: Actions db a -> FixtureContext db fix -> IO a
+withoutFixture action (db, _) =
+ usingConnectionPool (pool db) (transactionally_ action)
+
-- | Helper for writing tests. Wrapper around 'it' that uses the passed
-- in 'TestDB' to run a db transaction automatically for the test.
-itDB :: String -> Actions schema a -> SpecWith (TestDB (K Connection schema))
-itDB msg action = it msg $ void . withDB action
+itDB :: String -> Actions db a -> SpecWith (FixtureContext db ())
+itDB msg action = it msg $ void . withoutFixture action
+
+-- | Helper for writing tests. Wrapper around 'it' that uses the passed
+-- in 'TestDB' to run a db transaction automatically for the test,
+-- plus the result of the fixtures.
+itDBF :: String -> (fix -> Actions db a) -> SpecWith (FixtureContext db fix)
+itDBF msg action = it msg $ void . withFixture action
+
+itDBF_ :: String -> Actions db a -> SpecWith (FixtureContext db fix)
+itDBF_ msg action = it msg $ void . withoutFixture action
-- | Wraps 'describe' with a
--
--
-- hook for stopping a db.
describeDB
- :: AlignedList (Migration (Terminally PQ IO)) schema0 schema
- -> Fixtures schema
+ :: Migratory def (IsoQ (Indexed PQ IO ()))
+ => Migrations def db0 db
+ -> Fixtures db ()
-> String
- -> SpecWith (SquealContext schema)
+ -> SpecWith (FixtureContext db ())
-> Spec
describeDB migrate fixture str =
- beforeAll (setupDB migrate fixture) . afterAll teardownDB . describe str
+ beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str
+
+-- | Like `decribeDB`, but allow fixtures to pass
+-- | a result to all specs
+describeFixtures
+ :: Migratory def (IsoQ (Indexed PQ IO ()))
+ => Migrations def db0 db
+ -> Fixtures db fix
+ -> String
+ -> SpecWith (FixtureContext db fix)
+ -> Spec
+describeFixtures migrate fixture str =
+ beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str
projects / github / fretlink / squeal-hspec.git / blobdiff