diff options
Diffstat (limited to 'src/Squeal')
-rw-r--r-- | src/Squeal/PostgreSQL/Hspec.hs | 57 |
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 | |||
27 | import qualified Database.Postgres.Temp as Temp | 27 | import qualified Database.Postgres.Temp as Temp |
28 | import Generics.SOP (K) | 28 | import Generics.SOP (K) |
29 | import Squeal.PostgreSQL | 29 | import Squeal.PostgreSQL |
30 | import Squeal.PostgreSQL.Pool | ||
31 | import System.Environment (lookupEnv) | 30 | import System.Environment (lookupEnv) |
32 | import Test.Hspec | 31 | import Test.Hspec |
33 | 32 | ||
34 | data TestDB a = TestDB | 33 | data 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 | ||
42 | type Fixtures schema a = (Pool (K Connection schema) -> IO a) | 41 | type Fixtures db a = (Pool (K Connection db) -> IO a) |
43 | type Actions schema a = PoolPQ schema IO a | 42 | type Actions db a = PQ db db IO a |
44 | type SquealContext schema = TestDB (K Connection schema) | 43 | type FixtureContext db fix = (TestDB db, fix) |
45 | type FixtureContext schema fix = (SquealContext schema, fix) | 44 | type Migrations def from to = Path (Migration def) from to |
46 | 45 | ||
47 | testDBEnv :: String | 46 | testDBEnv :: String |
48 | testDBEnv = "TEST_DB_CONNECTION_STRING" | 47 | testDBEnv = "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 |
62 | setupDB | 61 | setupDB |
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) |
66 | setupDB migration fixtures = do | 66 | setupDB 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 |
82 | teardownDB | 82 | teardownDB |
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 () |
86 | teardownDB migration TestDB {..} = do | 87 | teardownDB 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 |
92 | withPool :: TestDB (K Connection schema) -> Actions schema a -> IO a | 93 | withPool :: TestDB db -> Actions db a -> IO a |
93 | withPool testDB = liftBase . flip runPoolPQ (pool testDB) | 94 | withPool testDB = liftBase . usingConnectionPool (pool testDB) |
94 | 95 | ||
95 | -- | Run an 'DB' transaction, using 'transactionally_' | 96 | -- | Run an 'DB' transaction, using 'transactionally_' |
96 | withDB :: Actions schema a -> TestDB (K Connection schema) -> IO a | 97 | withDB :: Actions db a -> TestDB db -> IO a |
97 | withDB action testDB = | 98 | withDB 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' |
101 | runDB :: TestDB (K Connection schema) -> Actions schema a -> IO a | 102 | runDB :: TestDB db -> Actions db a -> IO a |
102 | runDB = flip withDB | 103 | runDB = flip withDB |
103 | 104 | ||
104 | withFixture :: (fix -> Actions schema a) -> FixtureContext schema fix -> IO a | 105 | withFixture :: (fix -> Actions db a) -> FixtureContext db fix -> IO a |
105 | withFixture action (db, fix) = | 106 | withFixture action (db, fix) = |
106 | runPoolPQ (transactionally_ $ action fix) (pool db) | 107 | usingConnectionPool (pool db) (transactionally_ $ action fix) |
107 | 108 | ||
108 | withoutFixture :: Actions schema a -> FixtureContext schema fix -> IO a | 109 | withoutFixture :: Actions db a -> FixtureContext db fix -> IO a |
109 | withoutFixture action (db, _) = | 110 | withoutFixture 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. |
114 | itDB :: String -> Actions schema a -> SpecWith (FixtureContext schema ()) | 115 | itDB :: String -> Actions db a -> SpecWith (FixtureContext db ()) |
115 | itDB msg action = it msg $ void . withoutFixture action | 116 | itDB 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. |
120 | itDBF :: String -> (fix -> Actions schema a) -> SpecWith (FixtureContext schema fix) | 121 | itDBF :: String -> (fix -> Actions db a) -> SpecWith (FixtureContext db fix) |
121 | itDBF msg action = it msg $ void . withFixture action | 122 | itDBF msg action = it msg $ void . withFixture action |
122 | 123 | ||
123 | itDBF_ :: String -> Actions schema a -> SpecWith (FixtureContext schema fix) | 124 | itDBF_ :: String -> Actions db a -> SpecWith (FixtureContext db fix) |
124 | itDBF_ msg action = it msg $ void . withoutFixture action | 125 | itDBF_ 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. |
139 | describeDB | 140 | describeDB |
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 |
145 | describeDB migrate fixture str = | 147 | describeDB 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 |
150 | describeFixtures | 152 | describeFixtures |
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 |
156 | describeFixtures migrate fixture str = | 159 | describeFixtures 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 |