]>
Commit | Line | Data |
---|---|---|
aa94c1a5 R |
1 | {-| |
2 | Helpers for creating database tests with hspec and squeal, inspired by Jonathan Fischoff's | |
3 | [hspec-pg-transact](http://hackage.haskell.org/package/hspec-pg-transact). | |
4 | ||
5 | This uses @tmp-postgres@ to automatically and connect to a temporary instance of postgres on a random port. | |
6 | ||
7 | Tests can be written with 'itDB' which is wrapper around 'it' that uses the passed in 'TestDB' to run a db transaction automatically for the test. | |
8 | ||
9 | The libary also provides a few other functions for more fine grained control over running transactions in tests. | |
10 | -} | |
aa94c1a5 | 11 | {-# LANGUAGE FlexibleContexts #-} |
aa94c1a5 R |
12 | {-# LANGUAGE MonoLocalBinds #-} |
13 | {-# LANGUAGE RankNTypes #-} | |
14 | {-# LANGUAGE RecordWildCards #-} | |
dd35032c | 15 | {-# LANGUAGE TupleSections #-} |
aa94c1a5 | 16 | {-# LANGUAGE TypeInType #-} |
aa94c1a5 R |
17 | module Squeal.PostgreSQL.Hspec |
18 | where | |
19 | ||
20 | import Control.Exception | |
21 | import Control.Monad | |
bcc400ae AV |
22 | import Control.Monad.Base (liftBase) |
23 | import Data.ByteString (ByteString) | |
24 | import qualified Data.ByteString.Char8 as BSC | |
25 | import Database.Postgres.Temp as Temp | |
26 | import Squeal.PostgreSQL (Connection, | |
27 | Indexed, IsoQ, K, | |
28 | Migration, | |
29 | Migratory, PQ, | |
30 | Path, Pool, | |
31 | createConnectionPool, | |
32 | destroyConnectionPool, | |
33 | migrateDown, | |
34 | migrateUp, | |
35 | usingConnectionPool, | |
36 | withConnection) | |
37 | import Squeal.PostgreSQL.Session.Transaction.Unsafe (transactionally_) | |
38 | import System.Environment (lookupEnv) | |
aa94c1a5 R |
39 | import Test.Hspec |
40 | ||
41 | data TestDB a = TestDB | |
dd35032c | 42 | { tempDB :: Maybe Temp.DB |
aa94c1a5 | 43 | -- ^ Handle for temporary @postgres@ process |
4c2683dd | 44 | , pool :: Pool (K Connection a) |
aa94c1a5 | 45 | -- ^ Pool of 50 connections to the temporary @postgres@ |
dd35032c | 46 | , connectionString :: ByteString |
aa94c1a5 R |
47 | } |
48 | ||
4c2683dd AD |
49 | type Fixtures db a = (Pool (K Connection db) -> IO a) |
50 | type Actions db a = PQ db db IO a | |
51 | type FixtureContext db fix = (TestDB db, fix) | |
52 | type Migrations def from to = Path (Migration def) from to | |
aa94c1a5 | 53 | |
dd35032c R |
54 | testDBEnv :: String |
55 | testDBEnv = "TEST_DB_CONNECTION_STRING" | |
56 | ||
57 | getOrCreateConnectionString :: IO (ByteString, Maybe Temp.DB) | |
58 | getOrCreateConnectionString = do | |
59 | hasConnectionString <- lookupEnv testDBEnv | |
60 | maybe createTempDB (pure . (, Nothing) . BSC.pack) hasConnectionString | |
61 | ||
62 | createTempDB :: IO (ByteString, Maybe Temp.DB) | |
63 | createTempDB = do | |
cfe36707 AD |
64 | tempDB <- either throwIO return =<< Temp.start |
65 | let connectionString = Temp.toConnectionString tempDB | |
dd35032c R |
66 | pure (connectionString, Just tempDB) |
67 | ||
aa94c1a5 R |
68 | -- | Start a temporary @postgres@ process and create a pool of connections to it |
69 | setupDB | |
4c2683dd AD |
70 | :: Migratory def (IsoQ (Indexed PQ IO ())) |
71 | => Migrations def schema0 schema | |
b47ba97b AD |
72 | -> Fixtures schema fix |
73 | -> IO (FixtureContext schema fix) | |
aa94c1a5 | 74 | setupDB migration fixtures = do |
dd35032c R |
75 | (connectionString, tempDB) <- getOrCreateConnectionString |
76 | BSC.putStrLn connectionString | |
aa94c1a5 R |
77 | let singleStripe = 1 |
78 | keepConnectionForOneHour = 3600 | |
79 | poolSizeOfFifty = 50 | |
80 | pool <- createConnectionPool | |
81 | connectionString | |
82 | singleStripe | |
83 | keepConnectionForOneHour | |
84 | poolSizeOfFifty | |
d8e546eb | 85 | withConnection connectionString (migrateUp migration) |
b47ba97b AD |
86 | res <- fixtures pool |
87 | pure (TestDB {..}, res) | |
aa94c1a5 R |
88 | |
89 | -- | Drop all the connections and shutdown the @postgres@ process | |
dd35032c | 90 | teardownDB |
4c2683dd AD |
91 | :: Migratory def (IsoQ (Indexed PQ IO ())) |
92 | => Migrations def schema0 schema | |
dd35032c R |
93 | -> TestDB a |
94 | -> IO () | |
95 | teardownDB migration TestDB {..} = do | |
96 | withConnection connectionString (migrateDown migration) | |
4c2683dd | 97 | destroyConnectionPool pool |
dd35032c | 98 | maybe (pure ()) (void . Temp.stop) tempDB |
aa94c1a5 R |
99 | |
100 | -- | Run an 'IO' action with a connection from the pool | |
4c2683dd AD |
101 | withPool :: TestDB db -> Actions db a -> IO a |
102 | withPool testDB = liftBase . usingConnectionPool (pool testDB) | |
aa94c1a5 R |
103 | |
104 | -- | Run an 'DB' transaction, using 'transactionally_' | |
4c2683dd | 105 | withDB :: Actions db a -> TestDB db -> IO a |
aa94c1a5 | 106 | withDB action testDB = |
4c2683dd | 107 | usingConnectionPool (pool testDB) (transactionally_ action) |
aa94c1a5 R |
108 | |
109 | -- | Flipped version of 'withDB' | |
4c2683dd | 110 | runDB :: TestDB db -> Actions db a -> IO a |
aa94c1a5 R |
111 | runDB = flip withDB |
112 | ||
4c2683dd | 113 | withFixture :: (fix -> Actions db a) -> FixtureContext db fix -> IO a |
b47ba97b | 114 | withFixture action (db, fix) = |
4c2683dd | 115 | usingConnectionPool (pool db) (transactionally_ $ action fix) |
b47ba97b | 116 | |
4c2683dd | 117 | withoutFixture :: Actions db a -> FixtureContext db fix -> IO a |
b47ba97b | 118 | withoutFixture action (db, _) = |
4c2683dd | 119 | usingConnectionPool (pool db) (transactionally_ action) |
b47ba97b | 120 | |
aa94c1a5 R |
121 | -- | Helper for writing tests. Wrapper around 'it' that uses the passed |
122 | -- in 'TestDB' to run a db transaction automatically for the test. | |
4c2683dd | 123 | itDB :: String -> Actions db a -> SpecWith (FixtureContext db ()) |
b47ba97b AD |
124 | itDB msg action = it msg $ void . withoutFixture action |
125 | ||
126 | -- | Helper for writing tests. Wrapper around 'it' that uses the passed | |
127 | -- in 'TestDB' to run a db transaction automatically for the test, | |
128 | -- plus the result of the fixtures. | |
4c2683dd | 129 | itDBF :: String -> (fix -> Actions db a) -> SpecWith (FixtureContext db fix) |
b47ba97b AD |
130 | itDBF msg action = it msg $ void . withFixture action |
131 | ||
4c2683dd | 132 | itDBF_ :: String -> Actions db a -> SpecWith (FixtureContext db fix) |
b47ba97b | 133 | itDBF_ msg action = it msg $ void . withoutFixture action |
aa94c1a5 R |
134 | |
135 | -- | Wraps 'describe' with a | |
136 | -- | |
137 | -- @ | |
138 | -- 'beforeAll' ('setupDB' migrate) | |
139 | -- @ | |
140 | -- | |
141 | -- hook for creating a db and a | |
142 | -- | |
143 | -- @ | |
144 | -- 'afterAll' 'teardownDB' | |
145 | -- @ | |
146 | -- | |
147 | -- hook for stopping a db. | |
148 | describeDB | |
4c2683dd AD |
149 | :: Migratory def (IsoQ (Indexed PQ IO ())) |
150 | => Migrations def db0 db | |
151 | -> Fixtures db () | |
aa94c1a5 | 152 | -> String |
4c2683dd | 153 | -> SpecWith (FixtureContext db ()) |
aa94c1a5 R |
154 | -> Spec |
155 | describeDB migrate fixture str = | |
b47ba97b AD |
156 | beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str |
157 | ||
158 | -- | Like `decribeDB`, but allow fixtures to pass | |
159 | -- | a result to all specs | |
160 | describeFixtures | |
4c2683dd AD |
161 | :: Migratory def (IsoQ (Indexed PQ IO ())) |
162 | => Migrations def db0 db | |
163 | -> Fixtures db fix | |
b47ba97b | 164 | -> String |
4c2683dd | 165 | -> SpecWith (FixtureContext db fix) |
b47ba97b AD |
166 | -> Spec |
167 | describeFixtures migrate fixture str = | |
168 | beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str |