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