1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
{-|
Helpers for creating database tests with hspec and squeal, inspired by Jonathan Fischoff's
[hspec-pg-transact](http://hackage.haskell.org/package/hspec-pg-transact).
This uses @tmp-postgres@ to automatically and connect to a temporary instance of postgres on a random port.
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.
The libary also provides a few other functions for more fine grained control over running transactions in tests.
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
module Squeal.PostgreSQL.Hspec
where
import Control.Exception
import Control.Monad
import Control.Monad.Base (liftBase)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BSC
import qualified Database.Postgres.Temp as Temp
import Generics.SOP (K)
import Squeal.PostgreSQL
import System.Environment (lookupEnv)
import Test.Hspec
data TestDB a = TestDB
{ tempDB :: Maybe Temp.DB
-- ^ Handle for temporary @postgres@ process
, pool :: Pool (K Connection a)
-- ^ Pool of 50 connections to the temporary @postgres@
, connectionString :: ByteString
}
type Fixtures db a = (Pool (K Connection db) -> IO a)
type Actions db a = PQ db db IO a
type FixtureContext db fix = (TestDB db, fix)
type Migrations def from to = Path (Migration def) from to
testDBEnv :: String
testDBEnv = "TEST_DB_CONNECTION_STRING"
getOrCreateConnectionString :: IO (ByteString, Maybe Temp.DB)
getOrCreateConnectionString = do
hasConnectionString <- lookupEnv testDBEnv
maybe createTempDB (pure . (, Nothing) . BSC.pack) hasConnectionString
createTempDB :: IO (ByteString, Maybe Temp.DB)
createTempDB = do
tempDB <- either throwIO return =<< Temp.startAndLogToTmp []
let connectionString = BSC.pack (Temp.connectionString tempDB)
pure (connectionString, Just tempDB)
-- | Start a temporary @postgres@ process and create a pool of connections to it
setupDB
:: Migratory def (IsoQ (Indexed PQ IO ()))
=> Migrations def schema0 schema
-> Fixtures schema fix
-> IO (FixtureContext schema fix)
setupDB migration fixtures = do
(connectionString, tempDB) <- getOrCreateConnectionString
BSC.putStrLn connectionString
let singleStripe = 1
keepConnectionForOneHour = 3600
poolSizeOfFifty = 50
pool <- createConnectionPool
connectionString
singleStripe
keepConnectionForOneHour
poolSizeOfFifty
withConnection connectionString (migrateUp migration)
res <- fixtures pool
pure (TestDB {..}, res)
-- | Drop all the connections and shutdown the @postgres@ process
teardownDB
:: Migratory def (IsoQ (Indexed PQ IO ()))
=> Migrations def schema0 schema
-> TestDB a
-> IO ()
teardownDB migration TestDB {..} = do
withConnection connectionString (migrateDown migration)
destroyConnectionPool pool
maybe (pure ()) (void . Temp.stop) tempDB
-- | Run an 'IO' action with a connection from the pool
withPool :: TestDB db -> Actions db a -> IO a
withPool testDB = liftBase . usingConnectionPool (pool testDB)
-- | Run an 'DB' transaction, using 'transactionally_'
withDB :: Actions db a -> TestDB db -> IO a
withDB action testDB =
usingConnectionPool (pool testDB) (transactionally_ action)
-- | Flipped version of 'withDB'
runDB :: TestDB db -> Actions db a -> IO a
runDB = flip withDB
withFixture :: (fix -> Actions db a) -> FixtureContext db fix -> IO a
withFixture action (db, fix) =
usingConnectionPool (pool db) (transactionally_ $ action fix)
withoutFixture :: Actions db a -> FixtureContext db fix -> IO a
withoutFixture action (db, _) =
usingConnectionPool (pool db) (transactionally_ action)
-- | Helper for writing tests. Wrapper around 'it' that uses the passed
-- in 'TestDB' to run a db transaction automatically for the test.
itDB :: String -> Actions db a -> SpecWith (FixtureContext db ())
itDB msg action = it msg $ void . withoutFixture action
-- | Helper for writing tests. Wrapper around 'it' that uses the passed
-- in 'TestDB' to run a db transaction automatically for the test,
-- plus the result of the fixtures.
itDBF :: String -> (fix -> Actions db a) -> SpecWith (FixtureContext db fix)
itDBF msg action = it msg $ void . withFixture action
itDBF_ :: String -> Actions db a -> SpecWith (FixtureContext db fix)
itDBF_ msg action = it msg $ void . withoutFixture action
-- | Wraps 'describe' with a
--
-- @
-- 'beforeAll' ('setupDB' migrate)
-- @
--
-- hook for creating a db and a
--
-- @
-- 'afterAll' 'teardownDB'
-- @
--
-- hook for stopping a db.
describeDB
:: Migratory def (IsoQ (Indexed PQ IO ()))
=> Migrations def db0 db
-> Fixtures db ()
-> String
-> SpecWith (FixtureContext db ())
-> Spec
describeDB migrate fixture str =
beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str
-- | Like `decribeDB`, but allow fixtures to pass
-- | a result to all specs
describeFixtures
:: Migratory def (IsoQ (Indexed PQ IO ()))
=> Migrations def db0 db
-> Fixtures db fix
-> String
-> SpecWith (FixtureContext db fix)
-> Spec
describeFixtures migrate fixture str =
beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str
|
