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