]> git.immae.eu Git - github/fretlink/squeal-hspec.git/blame - src/Squeal/PostgreSQL/Hspec.hs
bump to squeal 0.6
[github/fretlink/squeal-hspec.git] / src / Squeal / PostgreSQL / Hspec.hs
CommitLineData
aa94c1a5
R
1{-|
2Helpers 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
5This uses @tmp-postgres@ to automatically and connect to a temporary instance of postgres on a random port.
6
7Tests 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
9The 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 #-}
19module Squeal.PostgreSQL.Hspec
20where
21
22import Control.Exception
23import Control.Monad
d8e546eb 24import Control.Monad.Base (liftBase)
dd35032c 25import Data.ByteString (ByteString)
d8e546eb
R
26import qualified Data.ByteString.Char8 as BSC
27import qualified Database.Postgres.Temp as Temp
28import Generics.SOP (K)
aa94c1a5 29import Squeal.PostgreSQL
dd35032c 30import System.Environment (lookupEnv)
aa94c1a5
R
31import Test.Hspec
32
33data TestDB a = TestDB
dd35032c 34 { tempDB :: Maybe Temp.DB
aa94c1a5 35 -- ^ Handle for temporary @postgres@ process
4c2683dd 36 , pool :: Pool (K Connection a)
aa94c1a5 37 -- ^ Pool of 50 connections to the temporary @postgres@
dd35032c 38 , connectionString :: ByteString
aa94c1a5
R
39 }
40
4c2683dd
AD
41type Fixtures db a = (Pool (K Connection db) -> IO a)
42type Actions db a = PQ db db IO a
43type FixtureContext db fix = (TestDB db, fix)
44type Migrations def from to = Path (Migration def) from to
aa94c1a5 45
dd35032c
R
46testDBEnv :: String
47testDBEnv = "TEST_DB_CONNECTION_STRING"
48
49getOrCreateConnectionString :: IO (ByteString, Maybe Temp.DB)
50getOrCreateConnectionString = do
51 hasConnectionString <- lookupEnv testDBEnv
52 maybe createTempDB (pure . (, Nothing) . BSC.pack) hasConnectionString
53
54createTempDB :: IO (ByteString, Maybe Temp.DB)
55createTempDB = do
56 tempDB <- either throwIO return =<< Temp.startAndLogToTmp []
57 let connectionString = BSC.pack (Temp.connectionString tempDB)
58 pure (connectionString, Just tempDB)
59
aa94c1a5
R
60-- | Start a temporary @postgres@ process and create a pool of connections to it
61setupDB
4c2683dd
AD
62 :: Migratory def (IsoQ (Indexed PQ IO ()))
63 => Migrations def schema0 schema
b47ba97b
AD
64 -> Fixtures schema fix
65 -> IO (FixtureContext schema fix)
aa94c1a5 66setupDB 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 82teardownDB
4c2683dd
AD
83 :: Migratory def (IsoQ (Indexed PQ IO ()))
84 => Migrations def schema0 schema
dd35032c
R
85 -> TestDB a
86 -> IO ()
87teardownDB migration TestDB {..} = do
88 withConnection connectionString (migrateDown migration)
4c2683dd 89 destroyConnectionPool pool
dd35032c 90 maybe (pure ()) (void . Temp.stop) tempDB
aa94c1a5
R
91
92-- | Run an 'IO' action with a connection from the pool
4c2683dd
AD
93withPool :: TestDB db -> Actions db a -> IO a
94withPool testDB = liftBase . usingConnectionPool (pool testDB)
aa94c1a5
R
95
96-- | Run an 'DB' transaction, using 'transactionally_'
4c2683dd 97withDB :: Actions db a -> TestDB db -> IO a
aa94c1a5 98withDB action testDB =
4c2683dd 99 usingConnectionPool (pool testDB) (transactionally_ action)
aa94c1a5
R
100
101-- | Flipped version of 'withDB'
4c2683dd 102runDB :: TestDB db -> Actions db a -> IO a
aa94c1a5
R
103runDB = flip withDB
104
4c2683dd 105withFixture :: (fix -> Actions db a) -> FixtureContext db fix -> IO a
b47ba97b 106withFixture action (db, fix) =
4c2683dd 107 usingConnectionPool (pool db) (transactionally_ $ action fix)
b47ba97b 108
4c2683dd 109withoutFixture :: Actions db a -> FixtureContext db fix -> IO a
b47ba97b 110withoutFixture action (db, _) =
4c2683dd 111 usingConnectionPool (pool db) (transactionally_ action)
b47ba97b 112
aa94c1a5
R
113-- | Helper for writing tests. Wrapper around 'it' that uses the passed
114-- in 'TestDB' to run a db transaction automatically for the test.
4c2683dd 115itDB :: String -> Actions db a -> SpecWith (FixtureContext db ())
b47ba97b
AD
116itDB msg action = it msg $ void . withoutFixture action
117
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.
4c2683dd 121itDBF :: String -> (fix -> Actions db a) -> SpecWith (FixtureContext db fix)
b47ba97b
AD
122itDBF msg action = it msg $ void . withFixture action
123
4c2683dd 124itDBF_ :: String -> Actions db a -> SpecWith (FixtureContext db fix)
b47ba97b 125itDBF_ msg action = it msg $ void . withoutFixture action
aa94c1a5
R
126
127-- | Wraps 'describe' with a
128--
129-- @
130-- 'beforeAll' ('setupDB' migrate)
131-- @
132--
133-- hook for creating a db and a
134--
135-- @
136-- 'afterAll' 'teardownDB'
137-- @
138--
139-- hook for stopping a db.
140describeDB
4c2683dd
AD
141 :: Migratory def (IsoQ (Indexed PQ IO ()))
142 => Migrations def db0 db
143 -> Fixtures db ()
aa94c1a5 144 -> String
4c2683dd 145 -> SpecWith (FixtureContext db ())
aa94c1a5
R
146 -> Spec
147describeDB migrate fixture str =
b47ba97b
AD
148 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str
149
150-- | Like `decribeDB`, but allow fixtures to pass
151-- | a result to all specs
152describeFixtures
4c2683dd
AD
153 :: Migratory def (IsoQ (Indexed PQ IO ()))
154 => Migrations def db0 db
155 -> Fixtures db fix
b47ba97b 156 -> String
4c2683dd 157 -> SpecWith (FixtureContext db fix)
b47ba97b
AD
158 -> Spec
159describeFixtures migrate fixture str =
160 beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str