]>
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 | |
d8e546eb | 22 | import Control.Monad.Base (liftBase) |
dd35032c | 23 | import Data.ByteString (ByteString) |
d8e546eb | 24 | import qualified Data.ByteString.Char8 as BSC |
cfe36707 | 25 | import Database.Postgres.Temp as Temp |
aa94c1a5 | 26 | import Squeal.PostgreSQL |
dd35032c | 27 | import System.Environment (lookupEnv) |
aa94c1a5 R |
28 | import Test.Hspec |
29 | ||
30 | data TestDB a = TestDB | |
dd35032c | 31 | { tempDB :: Maybe Temp.DB |
aa94c1a5 | 32 | -- ^ Handle for temporary @postgres@ process |
4c2683dd | 33 | , pool :: Pool (K Connection a) |
aa94c1a5 | 34 | -- ^ Pool of 50 connections to the temporary @postgres@ |
dd35032c | 35 | , connectionString :: ByteString |
aa94c1a5 R |
36 | } |
37 | ||
4c2683dd AD |
38 | type Fixtures db a = (Pool (K Connection db) -> IO a) |
39 | type Actions db a = PQ db db IO a | |
40 | type FixtureContext db fix = (TestDB db, fix) | |
41 | type Migrations def from to = Path (Migration def) from to | |
aa94c1a5 | 42 | |
dd35032c R |
43 | testDBEnv :: String |
44 | testDBEnv = "TEST_DB_CONNECTION_STRING" | |
45 | ||
46 | getOrCreateConnectionString :: IO (ByteString, Maybe Temp.DB) | |
47 | getOrCreateConnectionString = do | |
48 | hasConnectionString <- lookupEnv testDBEnv | |
49 | maybe createTempDB (pure . (, Nothing) . BSC.pack) hasConnectionString | |
50 | ||
51 | createTempDB :: IO (ByteString, Maybe Temp.DB) | |
52 | createTempDB = do | |
cfe36707 AD |
53 | tempDB <- either throwIO return =<< Temp.start |
54 | let connectionString = Temp.toConnectionString tempDB | |
dd35032c R |
55 | pure (connectionString, Just tempDB) |
56 | ||
aa94c1a5 R |
57 | -- | Start a temporary @postgres@ process and create a pool of connections to it |
58 | setupDB | |
4c2683dd AD |
59 | :: Migratory def (IsoQ (Indexed PQ IO ())) |
60 | => Migrations def schema0 schema | |
b47ba97b AD |
61 | -> Fixtures schema fix |
62 | -> IO (FixtureContext schema fix) | |
aa94c1a5 | 63 | setupDB migration fixtures = do |
dd35032c R |
64 | (connectionString, tempDB) <- getOrCreateConnectionString |
65 | BSC.putStrLn connectionString | |
aa94c1a5 R |
66 | let singleStripe = 1 |
67 | keepConnectionForOneHour = 3600 | |
68 | poolSizeOfFifty = 50 | |
69 | pool <- createConnectionPool | |
70 | connectionString | |
71 | singleStripe | |
72 | keepConnectionForOneHour | |
73 | poolSizeOfFifty | |
d8e546eb | 74 | withConnection connectionString (migrateUp migration) |
b47ba97b AD |
75 | res <- fixtures pool |
76 | pure (TestDB {..}, res) | |
aa94c1a5 R |
77 | |
78 | -- | Drop all the connections and shutdown the @postgres@ process | |
dd35032c | 79 | teardownDB |
4c2683dd AD |
80 | :: Migratory def (IsoQ (Indexed PQ IO ())) |
81 | => Migrations def schema0 schema | |
dd35032c R |
82 | -> TestDB a |
83 | -> IO () | |
84 | teardownDB migration TestDB {..} = do | |
85 | withConnection connectionString (migrateDown migration) | |
4c2683dd | 86 | destroyConnectionPool pool |
dd35032c | 87 | maybe (pure ()) (void . Temp.stop) tempDB |
aa94c1a5 R |
88 | |
89 | -- | Run an 'IO' action with a connection from the pool | |
4c2683dd AD |
90 | withPool :: TestDB db -> Actions db a -> IO a |
91 | withPool testDB = liftBase . usingConnectionPool (pool testDB) | |
aa94c1a5 R |
92 | |
93 | -- | Run an 'DB' transaction, using 'transactionally_' | |
4c2683dd | 94 | withDB :: Actions db a -> TestDB db -> IO a |
aa94c1a5 | 95 | withDB action testDB = |
4c2683dd | 96 | usingConnectionPool (pool testDB) (transactionally_ action) |
aa94c1a5 R |
97 | |
98 | -- | Flipped version of 'withDB' | |
4c2683dd | 99 | runDB :: TestDB db -> Actions db a -> IO a |
aa94c1a5 R |
100 | runDB = flip withDB |
101 | ||
4c2683dd | 102 | withFixture :: (fix -> Actions db a) -> FixtureContext db fix -> IO a |
b47ba97b | 103 | withFixture action (db, fix) = |
4c2683dd | 104 | usingConnectionPool (pool db) (transactionally_ $ action fix) |
b47ba97b | 105 | |
4c2683dd | 106 | withoutFixture :: Actions db a -> FixtureContext db fix -> IO a |
b47ba97b | 107 | withoutFixture action (db, _) = |
4c2683dd | 108 | usingConnectionPool (pool db) (transactionally_ action) |
b47ba97b | 109 | |
aa94c1a5 R |
110 | -- | Helper for writing tests. Wrapper around 'it' that uses the passed |
111 | -- in 'TestDB' to run a db transaction automatically for the test. | |
4c2683dd | 112 | itDB :: String -> Actions db a -> SpecWith (FixtureContext db ()) |
b47ba97b AD |
113 | itDB msg action = it msg $ void . withoutFixture action |
114 | ||
115 | -- | Helper for writing tests. Wrapper around 'it' that uses the passed | |
116 | -- in 'TestDB' to run a db transaction automatically for the test, | |
117 | -- plus the result of the fixtures. | |
4c2683dd | 118 | itDBF :: String -> (fix -> Actions db a) -> SpecWith (FixtureContext db fix) |
b47ba97b AD |
119 | itDBF msg action = it msg $ void . withFixture action |
120 | ||
4c2683dd | 121 | itDBF_ :: String -> Actions db a -> SpecWith (FixtureContext db fix) |
b47ba97b | 122 | itDBF_ msg action = it msg $ void . withoutFixture action |
aa94c1a5 R |
123 | |
124 | -- | Wraps 'describe' with a | |
125 | -- | |
126 | -- @ | |
127 | -- 'beforeAll' ('setupDB' migrate) | |
128 | -- @ | |
129 | -- | |
130 | -- hook for creating a db and a | |
131 | -- | |
132 | -- @ | |
133 | -- 'afterAll' 'teardownDB' | |
134 | -- @ | |
135 | -- | |
136 | -- hook for stopping a db. | |
137 | describeDB | |
4c2683dd AD |
138 | :: Migratory def (IsoQ (Indexed PQ IO ())) |
139 | => Migrations def db0 db | |
140 | -> Fixtures db () | |
aa94c1a5 | 141 | -> String |
4c2683dd | 142 | -> SpecWith (FixtureContext db ()) |
aa94c1a5 R |
143 | -> Spec |
144 | describeDB migrate fixture str = | |
b47ba97b AD |
145 | beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str |
146 | ||
147 | -- | Like `decribeDB`, but allow fixtures to pass | |
148 | -- | a result to all specs | |
149 | describeFixtures | |
4c2683dd AD |
150 | :: Migratory def (IsoQ (Indexed PQ IO ())) |
151 | => Migrations def db0 db | |
152 | -> Fixtures db fix | |
b47ba97b | 153 | -> String |
4c2683dd | 154 | -> SpecWith (FixtureContext db fix) |
b47ba97b AD |
155 | -> Spec |
156 | describeFixtures migrate fixture str = | |
157 | beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str |