aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/Squeal/PostgreSQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Squeal/PostgreSQL')
-rw-r--r--src/Squeal/PostgreSQL/Hspec.hs49
1 files changed, 39 insertions, 10 deletions
diff --git a/src/Squeal/PostgreSQL/Hspec.hs b/src/Squeal/PostgreSQL/Hspec.hs
index d96d9a2..70d41b6 100644
--- a/src/Squeal/PostgreSQL/Hspec.hs
+++ b/src/Squeal/PostgreSQL/Hspec.hs
@@ -39,9 +39,10 @@ data TestDB a = TestDB
39 , connectionString :: ByteString 39 , connectionString :: ByteString
40 } 40 }
41 41
42type Fixtures schema = (Pool (K Connection schema) -> IO ()) 42type Fixtures schema a = (Pool (K Connection schema) -> IO a)
43type Actions schema a = PoolPQ schema IO a 43type Actions schema a = PoolPQ schema IO a
44type SquealContext schema = TestDB (K Connection schema) 44type SquealContext schema = TestDB (K Connection schema)
45type FixtureContext schema fix = (SquealContext schema, fix)
45 46
46testDBEnv :: String 47testDBEnv :: String
47testDBEnv = "TEST_DB_CONNECTION_STRING" 48testDBEnv = "TEST_DB_CONNECTION_STRING"
@@ -60,8 +61,8 @@ createTempDB = do
60-- | Start a temporary @postgres@ process and create a pool of connections to it 61-- | Start a temporary @postgres@ process and create a pool of connections to it
61setupDB 62setupDB
62 :: Migratory p => AlignedList (Migration p) schema0 schema 63 :: Migratory p => AlignedList (Migration p) schema0 schema
63 -> Fixtures schema 64 -> Fixtures schema fix
64 -> IO (SquealContext schema) 65 -> IO (FixtureContext schema fix)
65setupDB migration fixtures = do 66setupDB migration fixtures = do
66 (connectionString, tempDB) <- getOrCreateConnectionString 67 (connectionString, tempDB) <- getOrCreateConnectionString
67 BSC.putStrLn connectionString 68 BSC.putStrLn connectionString
@@ -74,8 +75,8 @@ setupDB migration fixtures = do
74 keepConnectionForOneHour 75 keepConnectionForOneHour
75 poolSizeOfFifty 76 poolSizeOfFifty
76 withConnection connectionString (migrateUp migration) 77 withConnection connectionString (migrateUp migration)
77 fixtures pool 78 res <- fixtures pool
78 pure TestDB {..} 79 pure (TestDB {..}, res)
79 80
80-- | Drop all the connections and shutdown the @postgres@ process 81-- | Drop all the connections and shutdown the @postgres@ process
81teardownDB 82teardownDB
@@ -100,10 +101,27 @@ withDB action testDB =
100runDB :: TestDB (K Connection schema) -> Actions schema a -> IO a 101runDB :: TestDB (K Connection schema) -> Actions schema a -> IO a
101runDB = flip withDB 102runDB = flip withDB
102 103
104withFixture :: (fix -> Actions schema a) -> FixtureContext schema fix -> IO a
105withFixture action (db, fix) =
106 runPoolPQ (transactionally_ $ action fix) (pool db)
107
108withoutFixture :: Actions schema a -> FixtureContext schema fix -> IO a
109withoutFixture action (db, _) =
110 runPoolPQ (transactionally_ action) (pool db)
111
103-- | Helper for writing tests. Wrapper around 'it' that uses the passed 112-- | Helper for writing tests. Wrapper around 'it' that uses the passed
104-- in 'TestDB' to run a db transaction automatically for the test. 113-- in 'TestDB' to run a db transaction automatically for the test.
105itDB :: String -> Actions schema a -> SpecWith (TestDB (K Connection schema)) 114itDB :: String -> Actions schema a -> SpecWith (FixtureContext schema ())
106itDB msg action = it msg $ void . withDB action 115itDB msg action = it msg $ void . withoutFixture action
116
117-- | Helper for writing tests. Wrapper around 'it' that uses the passed
118-- in 'TestDB' to run a db transaction automatically for the test,
119-- plus the result of the fixtures.
120itDBF :: String -> (fix -> Actions schema a) -> SpecWith (FixtureContext schema fix)
121itDBF msg action = it msg $ void . withFixture action
122
123itDBF_ :: String -> Actions schema a -> SpecWith (FixtureContext schema fix)
124itDBF_ msg action = it msg $ void . withoutFixture action
107 125
108-- | Wraps 'describe' with a 126-- | Wraps 'describe' with a
109-- 127--
@@ -120,9 +138,20 @@ itDB msg action = it msg $ void . withDB action
120-- hook for stopping a db. 138-- hook for stopping a db.
121describeDB 139describeDB
122 :: Migratory p => AlignedList (Migration p) schema0 schema 140 :: Migratory p => AlignedList (Migration p) schema0 schema
123 -> Fixtures schema 141 -> Fixtures schema ()
124 -> String 142 -> String
125 -> SpecWith (SquealContext schema) 143 -> SpecWith (FixtureContext schema ())
126 -> Spec 144 -> Spec
127describeDB migrate fixture str = 145describeDB migrate fixture str =
128 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate) . describe str 146 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str
147
148-- | Like `decribeDB`, but allow fixtures to pass
149-- | a result to all specs
150describeFixtures
151 :: Migratory p => AlignedList (Migration p) schema0 schema
152 -> Fixtures schema fix
153 -> String
154 -> SpecWith (FixtureContext schema fix)
155 -> Spec
156describeFixtures migrate fixture str =
157 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str