aboutsummaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Squeal/PostgreSQL/Hspec.hs57
1 files changed, 30 insertions, 27 deletions
diff --git a/src/Squeal/PostgreSQL/Hspec.hs b/src/Squeal/PostgreSQL/Hspec.hs
index 70d41b6..32ab189 100644
--- a/src/Squeal/PostgreSQL/Hspec.hs
+++ b/src/Squeal/PostgreSQL/Hspec.hs
@@ -27,22 +27,21 @@ import qualified Data.ByteString.Char8 as BSC
27import qualified Database.Postgres.Temp as Temp 27import qualified Database.Postgres.Temp as Temp
28import Generics.SOP (K) 28import Generics.SOP (K)
29import Squeal.PostgreSQL 29import Squeal.PostgreSQL
30import Squeal.PostgreSQL.Pool
31import System.Environment (lookupEnv) 30import System.Environment (lookupEnv)
32import Test.Hspec 31import Test.Hspec
33 32
34data TestDB a = TestDB 33data TestDB a = TestDB
35 { tempDB :: Maybe Temp.DB 34 { tempDB :: Maybe Temp.DB
36 -- ^ Handle for temporary @postgres@ process 35 -- ^ Handle for temporary @postgres@ process
37 , pool :: Pool a 36 , pool :: Pool (K Connection a)
38 -- ^ Pool of 50 connections to the temporary @postgres@ 37 -- ^ Pool of 50 connections to the temporary @postgres@
39 , connectionString :: ByteString 38 , connectionString :: ByteString
40 } 39 }
41 40
42type Fixtures schema a = (Pool (K Connection schema) -> IO a) 41type Fixtures db a = (Pool (K Connection db) -> IO a)
43type Actions schema a = PoolPQ schema IO a 42type Actions db a = PQ db db IO a
44type SquealContext schema = TestDB (K Connection schema) 43type FixtureContext db fix = (TestDB db, fix)
45type FixtureContext schema fix = (SquealContext schema, fix) 44type Migrations def from to = Path (Migration def) from to
46 45
47testDBEnv :: String 46testDBEnv :: String
48testDBEnv = "TEST_DB_CONNECTION_STRING" 47testDBEnv = "TEST_DB_CONNECTION_STRING"
@@ -60,7 +59,8 @@ createTempDB = do
60 59
61-- | Start a temporary @postgres@ process and create a pool of connections to it 60-- | Start a temporary @postgres@ process and create a pool of connections to it
62setupDB 61setupDB
63 :: Migratory p => AlignedList (Migration p) schema0 schema 62 :: Migratory def (IsoQ (Indexed PQ IO ()))
63 => Migrations def schema0 schema
64 -> Fixtures schema fix 64 -> Fixtures schema fix
65 -> IO (FixtureContext schema fix) 65 -> IO (FixtureContext schema fix)
66setupDB migration fixtures = do 66setupDB migration fixtures = do
@@ -80,47 +80,48 @@ setupDB migration fixtures = do
80 80
81-- | Drop all the connections and shutdown the @postgres@ process 81-- | Drop all the connections and shutdown the @postgres@ process
82teardownDB 82teardownDB
83 :: Migratory p => AlignedList (Migration p) schema0 schema 83 :: Migratory def (IsoQ (Indexed PQ IO ()))
84 => Migrations def schema0 schema
84 -> TestDB a 85 -> TestDB a
85 -> IO () 86 -> IO ()
86teardownDB migration TestDB {..} = do 87teardownDB migration TestDB {..} = do
87 withConnection connectionString (migrateDown migration) 88 withConnection connectionString (migrateDown migration)
88 destroyAllResources pool 89 destroyConnectionPool pool
89 maybe (pure ()) (void . Temp.stop) tempDB 90 maybe (pure ()) (void . Temp.stop) tempDB
90 91
91-- | Run an 'IO' action with a connection from the pool 92-- | Run an 'IO' action with a connection from the pool
92withPool :: TestDB (K Connection schema) -> Actions schema a -> IO a 93withPool :: TestDB db -> Actions db a -> IO a
93withPool testDB = liftBase . flip runPoolPQ (pool testDB) 94withPool testDB = liftBase . usingConnectionPool (pool testDB)
94 95
95-- | Run an 'DB' transaction, using 'transactionally_' 96-- | Run an 'DB' transaction, using 'transactionally_'
96withDB :: Actions schema a -> TestDB (K Connection schema) -> IO a 97withDB :: Actions db a -> TestDB db -> IO a
97withDB action testDB = 98withDB action testDB =
98 runPoolPQ (transactionally_ action) (pool testDB) 99 usingConnectionPool (pool testDB) (transactionally_ action)
99 100
100-- | Flipped version of 'withDB' 101-- | Flipped version of 'withDB'
101runDB :: TestDB (K Connection schema) -> Actions schema a -> IO a 102runDB :: TestDB db -> Actions db a -> IO a
102runDB = flip withDB 103runDB = flip withDB
103 104
104withFixture :: (fix -> Actions schema a) -> FixtureContext schema fix -> IO a 105withFixture :: (fix -> Actions db a) -> FixtureContext db fix -> IO a
105withFixture action (db, fix) = 106withFixture action (db, fix) =
106 runPoolPQ (transactionally_ $ action fix) (pool db) 107 usingConnectionPool (pool db) (transactionally_ $ action fix)
107 108
108withoutFixture :: Actions schema a -> FixtureContext schema fix -> IO a 109withoutFixture :: Actions db a -> FixtureContext db fix -> IO a
109withoutFixture action (db, _) = 110withoutFixture action (db, _) =
110 runPoolPQ (transactionally_ action) (pool db) 111 usingConnectionPool (pool db) (transactionally_ action)
111 112
112-- | Helper for writing tests. Wrapper around 'it' that uses the passed 113-- | Helper for writing tests. Wrapper around 'it' that uses the passed
113-- in 'TestDB' to run a db transaction automatically for the test. 114-- in 'TestDB' to run a db transaction automatically for the test.
114itDB :: String -> Actions schema a -> SpecWith (FixtureContext schema ()) 115itDB :: String -> Actions db a -> SpecWith (FixtureContext db ())
115itDB msg action = it msg $ void . withoutFixture action 116itDB msg action = it msg $ void . withoutFixture action
116 117
117-- | Helper for writing tests. Wrapper around 'it' that uses the passed 118-- | Helper for writing tests. Wrapper around 'it' that uses the passed
118-- in 'TestDB' to run a db transaction automatically for the test, 119-- in 'TestDB' to run a db transaction automatically for the test,
119-- plus the result of the fixtures. 120-- plus the result of the fixtures.
120itDBF :: String -> (fix -> Actions schema a) -> SpecWith (FixtureContext schema fix) 121itDBF :: String -> (fix -> Actions db a) -> SpecWith (FixtureContext db fix)
121itDBF msg action = it msg $ void . withFixture action 122itDBF msg action = it msg $ void . withFixture action
122 123
123itDBF_ :: String -> Actions schema a -> SpecWith (FixtureContext schema fix) 124itDBF_ :: String -> Actions db a -> SpecWith (FixtureContext db fix)
124itDBF_ msg action = it msg $ void . withoutFixture action 125itDBF_ msg action = it msg $ void . withoutFixture action
125 126
126-- | Wraps 'describe' with a 127-- | Wraps 'describe' with a
@@ -137,10 +138,11 @@ itDBF_ msg action = it msg $ void . withoutFixture action
137-- 138--
138-- hook for stopping a db. 139-- hook for stopping a db.
139describeDB 140describeDB
140 :: Migratory p => AlignedList (Migration p) schema0 schema 141 :: Migratory def (IsoQ (Indexed PQ IO ()))
141 -> Fixtures schema () 142 => Migrations def db0 db
143 -> Fixtures db ()
142 -> String 144 -> String
143 -> SpecWith (FixtureContext schema ()) 145 -> SpecWith (FixtureContext db ())
144 -> Spec 146 -> Spec
145describeDB migrate fixture str = 147describeDB migrate fixture str =
146 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str 148 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str
@@ -148,10 +150,11 @@ describeDB migrate fixture str =
148-- | Like `decribeDB`, but allow fixtures to pass 150-- | Like `decribeDB`, but allow fixtures to pass
149-- | a result to all specs 151-- | a result to all specs
150describeFixtures 152describeFixtures
151 :: Migratory p => AlignedList (Migration p) schema0 schema 153 :: Migratory def (IsoQ (Indexed PQ IO ()))
152 -> Fixtures schema fix 154 => Migrations def db0 db
155 -> Fixtures db fix
153 -> String 156 -> String
154 -> SpecWith (FixtureContext schema fix) 157 -> SpecWith (FixtureContext db fix)
155 -> Spec 158 -> Spec
156describeFixtures migrate fixture str = 159describeFixtures migrate fixture str =
157 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str 160 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str