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