diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Squeal/PostgreSQL/Hspec.hs | 114 |
1 files changed, 114 insertions, 0 deletions
diff --git a/src/Squeal/PostgreSQL/Hspec.hs b/src/Squeal/PostgreSQL/Hspec.hs new file mode 100644 index 0000000..44011b7 --- /dev/null +++ b/src/Squeal/PostgreSQL/Hspec.hs | |||
@@ -0,0 +1,114 @@ | |||
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 KindSignatures #-} | ||
14 | {-# LANGUAGE MonoLocalBinds #-} | ||
15 | {-# LANGUAGE RankNTypes #-} | ||
16 | {-# LANGUAGE RecordWildCards #-} | ||
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 Control.Monad.Trans.Control (MonadBaseControl) | ||
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.Migration | ||
31 | import Squeal.PostgreSQL.Pool | ||
32 | import Test.Hspec | ||
33 | |||
34 | data TestDB a = TestDB | ||
35 | { tempDB :: Temp.DB | ||
36 | -- ^ Handle for temporary @postgres@ process | ||
37 | , pool :: Pool a | ||
38 | -- ^ Pool of 50 connections to the temporary @postgres@ | ||
39 | } | ||
40 | |||
41 | type Migrations schema m a = (MonadBaseControl IO m) => | ||
42 | PQ (("schema_migrations" ::: Table MigrationsTable) ': '[]) | ||
43 | (("schema_migrations" ::: Table MigrationsTable) ': schema) m a | ||
44 | |||
45 | type Fixtures schema = (Pool (K Connection schema) -> IO ()) | ||
46 | type Actions schema a = PoolPQ schema IO a | ||
47 | type SquealContext (schema :: SchemaType) = TestDB (K Connection schema) | ||
48 | |||
49 | -- | Start a temporary @postgres@ process and create a pool of connections to it | ||
50 | setupDB | ||
51 | :: Migrations schema IO a | ||
52 | -> Fixtures schema | ||
53 | -> IO (SquealContext schema) | ||
54 | setupDB migration fixtures = do | ||
55 | tempDB <- either throwIO return =<< Temp.startAndLogToTmp [] | ||
56 | let connectionString = BSC.pack (Temp.connectionString tempDB) | ||
57 | putStrLn $ Temp.connectionString tempDB | ||
58 | let singleStripe = 1 | ||
59 | keepConnectionForOneHour = 3600 | ||
60 | poolSizeOfFifty = 50 | ||
61 | pool <- createConnectionPool | ||
62 | connectionString | ||
63 | singleStripe | ||
64 | keepConnectionForOneHour | ||
65 | poolSizeOfFifty | ||
66 | withConnection connectionString migration | ||
67 | fixtures pool | ||
68 | pure TestDB {..} | ||
69 | |||
70 | -- | Drop all the connections and shutdown the @postgres@ process | ||
71 | teardownDB :: TestDB a -> IO () | ||
72 | teardownDB TestDB {..} = do | ||
73 | destroyAllResources pool | ||
74 | void $ Temp.stop tempDB | ||
75 | |||
76 | -- | Run an 'IO' action with a connection from the pool | ||
77 | withPool :: TestDB (K Connection schema) -> Actions schema a -> IO a | ||
78 | withPool testDB = liftBase . flip runPoolPQ (pool testDB) | ||
79 | |||
80 | -- | Run an 'DB' transaction, using 'transactionally_' | ||
81 | withDB :: Actions schema a -> TestDB (K Connection schema) -> IO a | ||
82 | withDB action testDB = | ||
83 | runPoolPQ (transactionally_ action) (pool testDB) | ||
84 | |||
85 | -- | Flipped version of 'withDB' | ||
86 | runDB :: TestDB (K Connection schema) -> Actions schema a -> IO a | ||
87 | runDB = flip withDB | ||
88 | |||
89 | -- | Helper for writing tests. Wrapper around 'it' that uses the passed | ||
90 | -- in 'TestDB' to run a db transaction automatically for the test. | ||
91 | itDB :: String -> Actions schema a -> SpecWith (TestDB (K Connection schema)) | ||
92 | itDB msg action = it msg $ void . withDB action | ||
93 | |||
94 | -- | Wraps 'describe' with a | ||
95 | -- | ||
96 | -- @ | ||
97 | -- 'beforeAll' ('setupDB' migrate) | ||
98 | -- @ | ||
99 | -- | ||
100 | -- hook for creating a db and a | ||
101 | -- | ||
102 | -- @ | ||
103 | -- 'afterAll' 'teardownDB' | ||
104 | -- @ | ||
105 | -- | ||
106 | -- hook for stopping a db. | ||
107 | describeDB | ||
108 | :: Migrations schema IO a | ||
109 | -> Fixtures schema | ||
110 | -> String | ||
111 | -> SpecWith (SquealContext schema) | ||
112 | -> Spec | ||
113 | describeDB migrate fixture str = | ||
114 | beforeAll (setupDB migrate fixture) . afterAll teardownDB . describe str | ||