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).
5 This uses @tmp-postgres@ to automatically and connect to a temporary instance of postgres on a random port.
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.
9 The libary also provides a few other functions for more fine grained control over running transactions in tests.
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
22 import Control.Exception
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 System.Environment (lookupEnv)
33 data TestDB a = TestDB
34 { tempDB :: Maybe Temp.DB
35 -- ^ Handle for temporary @postgres@ process
36 , pool :: Pool (K Connection a)
37 -- ^ Pool of 50 connections to the temporary @postgres@
38 , connectionString :: ByteString
41 type Fixtures db a = (Pool (K Connection db) -> IO a)
42 type Actions db a = PQ db db IO a
43 type FixtureContext db fix = (TestDB db, fix)
44 type Migrations def from to = Path (Migration def) from to
47 testDBEnv = "TEST_DB_CONNECTION_STRING"
49 getOrCreateConnectionString :: IO (ByteString, Maybe Temp.DB)
50 getOrCreateConnectionString = do
51 hasConnectionString <- lookupEnv testDBEnv
52 maybe createTempDB (pure . (, Nothing) . BSC.pack) hasConnectionString
54 createTempDB :: IO (ByteString, Maybe Temp.DB)
56 tempDB <- either throwIO return =<< Temp.startAndLogToTmp []
57 let connectionString = BSC.pack (Temp.connectionString tempDB)
58 pure (connectionString, Just tempDB)
60 -- | Start a temporary @postgres@ process and create a pool of connections to it
62 :: Migratory def (IsoQ (Indexed PQ IO ()))
63 => Migrations def schema0 schema
64 -> Fixtures schema fix
65 -> IO (FixtureContext schema fix)
66 setupDB migration fixtures = do
67 (connectionString, tempDB) <- getOrCreateConnectionString
68 BSC.putStrLn connectionString
70 keepConnectionForOneHour = 3600
72 pool <- createConnectionPool
75 keepConnectionForOneHour
77 withConnection connectionString (migrateUp migration)
79 pure (TestDB {..}, res)
81 -- | Drop all the connections and shutdown the @postgres@ process
83 :: Migratory def (IsoQ (Indexed PQ IO ()))
84 => Migrations def schema0 schema
87 teardownDB migration TestDB {..} = do
88 withConnection connectionString (migrateDown migration)
89 destroyConnectionPool pool
90 maybe (pure ()) (void . Temp.stop) tempDB
92 -- | Run an 'IO' action with a connection from the pool
93 withPool :: TestDB db -> Actions db a -> IO a
94 withPool testDB = liftBase . usingConnectionPool (pool testDB)
96 -- | Run an 'DB' transaction, using 'transactionally_'
97 withDB :: Actions db a -> TestDB db -> IO a
98 withDB action testDB =
99 usingConnectionPool (pool testDB) (transactionally_ action)
101 -- | Flipped version of 'withDB'
102 runDB :: TestDB db -> Actions db a -> IO a
105 withFixture :: (fix -> Actions db a) -> FixtureContext db fix -> IO a
106 withFixture action (db, fix) =
107 usingConnectionPool (pool db) (transactionally_ $ action fix)
109 withoutFixture :: Actions db a -> FixtureContext db fix -> IO a
110 withoutFixture action (db, _) =
111 usingConnectionPool (pool db) (transactionally_ action)
113 -- | Helper for writing tests. Wrapper around 'it' that uses the passed
114 -- in 'TestDB' to run a db transaction automatically for the test.
115 itDB :: String -> Actions db a -> SpecWith (FixtureContext db ())
116 itDB msg action = it msg $ void . withoutFixture action
118 -- | Helper for writing tests. Wrapper around 'it' that uses the passed
119 -- in 'TestDB' to run a db transaction automatically for the test,
120 -- plus the result of the fixtures.
121 itDBF :: String -> (fix -> Actions db a) -> SpecWith (FixtureContext db fix)
122 itDBF msg action = it msg $ void . withFixture action
124 itDBF_ :: String -> Actions db a -> SpecWith (FixtureContext db fix)
125 itDBF_ msg action = it msg $ void . withoutFixture action
127 -- | Wraps 'describe' with a
130 -- 'beforeAll' ('setupDB' migrate)
133 -- hook for creating a db and a
136 -- 'afterAll' 'teardownDB'
139 -- hook for stopping a db.
141 :: Migratory def (IsoQ (Indexed PQ IO ()))
142 => Migrations def db0 db
145 -> SpecWith (FixtureContext db ())
147 describeDB migrate fixture str =
148 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str
150 -- | Like `decribeDB`, but allow fixtures to pass
151 -- | a result to all specs
153 :: Migratory def (IsoQ (Indexed PQ IO ()))
154 => Migrations def db0 db
157 -> SpecWith (FixtureContext db fix)
159 describeFixtures migrate fixture str =
160 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str