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 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
  20 where
  21
  22 import           Control.Exception
  23 import           Control.Monad
  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)
  31 import           Test.Hspec
  32
  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
  39   }
  40
  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
  45
  46 testDBEnv :: String
  47 testDBEnv = "TEST_DB_CONNECTION_STRING"
  48
  49 getOrCreateConnectionString :: IO (ByteString, Maybe Temp.DB)
  50 getOrCreateConnectionString = do
  51   hasConnectionString <- lookupEnv testDBEnv
  52   maybe createTempDB (pure . (, Nothing) . BSC.pack) hasConnectionString
  53
  54 createTempDB :: IO (ByteString, Maybe Temp.DB)
  55 createTempDB = do
  56   tempDB <- either throwIO return =<< Temp.startAndLogToTmp []
  57   let connectionString = BSC.pack (Temp.connectionString tempDB)
  58   pure (connectionString, Just tempDB)
  59
  60 -- | Start a temporary @postgres@ process and create a pool of connections to it
  61 setupDB
  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
  69   let singleStripe = 1
  70       keepConnectionForOneHour = 3600
  71       poolSizeOfFifty = 50
  72   pool <- createConnectionPool
  73      connectionString
  74      singleStripe
  75      keepConnectionForOneHour
  76      poolSizeOfFifty
  77   withConnection connectionString (migrateUp migration)
  78   res <- fixtures pool
  79   pure (TestDB {..}, res)
  80
  81 -- | Drop all the connections and shutdown the @postgres@ process
  82 teardownDB
  83   :: Migratory def (IsoQ (Indexed PQ IO ()))
  84   => Migrations def schema0 schema
  85   -> TestDB a
  86   -> IO ()
  87 teardownDB migration TestDB {..} = do
  88   withConnection connectionString (migrateDown migration)
  89   destroyConnectionPool pool
  90   maybe (pure ()) (void . Temp.stop) tempDB
  91
  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)
  95
  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)
 100
 101 -- | Flipped version of 'withDB'
 102 runDB :: TestDB db -> Actions db a -> IO a
 103 runDB = flip withDB
 104
 105 withFixture :: (fix -> Actions db a) -> FixtureContext db fix -> IO a
 106 withFixture action (db, fix) =
 107   usingConnectionPool (pool db) (transactionally_ $ action fix)
 108
 109 withoutFixture :: Actions db a -> FixtureContext db fix -> IO a
 110 withoutFixture action (db, _) =
 111   usingConnectionPool (pool db) (transactionally_ action)
 112
 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
 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.
 121 itDBF :: String -> (fix -> Actions db a) -> SpecWith (FixtureContext db fix)
 122 itDBF msg action = it msg $ void . withFixture action
 123
 124 itDBF_ :: String -> Actions db a -> SpecWith (FixtureContext db fix)
 125 itDBF_ msg action = it msg $ void . withoutFixture action
 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.
 140 describeDB
 141   :: Migratory def (IsoQ (Indexed PQ IO ()))
 142   => Migrations def db0 db
 143   -> Fixtures db ()
 144   -> String
 145   -> SpecWith (FixtureContext db ())
 146   -> Spec
 147 describeDB migrate fixture str =
 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
 152 describeFixtures
 153   :: Migratory def (IsoQ (Indexed PQ IO ()))
 154   => Migrations def db0 db
 155   -> Fixtures db fix
 156   -> String
 157   -> SpecWith (FixtureContext db fix)
 158   -> Spec
 159 describeFixtures migrate fixture str =
 160   beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str