src/Squeal/PostgreSQL/Hspec.hs

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