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           Squeal.PostgreSQL.Pool
  31 import           System.Environment     (lookupEnv)
  32 import           Test.Hspec
  33
  34 data TestDB a = TestDB
  35   { tempDB           :: Maybe Temp.DB
  36   -- ^ Handle for temporary @postgres@ process
  37   , pool             :: Pool a
  38   -- ^ Pool of 50 connections to the temporary @postgres@
  39   , connectionString :: ByteString
  40   }
  41
  42 type Fixtures schema a = (Pool (K Connection schema) -> IO a)
  43 type Actions schema a = PoolPQ schema IO a
  44 type SquealContext schema = TestDB (K Connection schema)
  45 type FixtureContext schema fix = (SquealContext schema, fix)
  46
  47 testDBEnv :: String
  48 testDBEnv = "TEST_DB_CONNECTION_STRING"
  49
  50 getOrCreateConnectionString :: IO (ByteString, Maybe Temp.DB)
  51 getOrCreateConnectionString = do
  52   hasConnectionString <- lookupEnv testDBEnv
  53   maybe createTempDB (pure . (, Nothing) . BSC.pack) hasConnectionString
  54
  55 createTempDB :: IO (ByteString, Maybe Temp.DB)
  56 createTempDB = do
  57   tempDB <- either throwIO return =<< Temp.startAndLogToTmp []
  58   let connectionString = BSC.pack (Temp.connectionString tempDB)
  59   pure (connectionString, Just tempDB)
  60
  61 -- | Start a temporary @postgres@ process and create a pool of connections to it
  62 setupDB
  63   :: Migratory p => AlignedList (Migration p) 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 p => AlignedList (Migration p) schema0 schema
  84   -> TestDB a
  85   -> IO ()
  86 teardownDB migration TestDB {..} = do
  87   withConnection connectionString (migrateDown migration)
  88   destroyAllResources pool
  89   maybe (pure ()) (void . Temp.stop) tempDB
  90
  91 -- | Run an 'IO' action with a connection from the pool
  92 withPool :: TestDB (K Connection schema) -> Actions schema a -> IO a
  93 withPool testDB = liftBase . flip runPoolPQ (pool testDB)
  94
  95 -- | Run an 'DB' transaction, using 'transactionally_'
  96 withDB :: Actions schema a -> TestDB (K Connection schema) -> IO a
  97 withDB action testDB =
  98   runPoolPQ (transactionally_ action) (pool testDB)
  99
 100 -- | Flipped version of 'withDB'
 101 runDB :: TestDB (K Connection schema) -> Actions schema a -> IO a
 102 runDB = flip withDB
 103
 104 withFixture :: (fix -> Actions schema a) -> FixtureContext schema fix -> IO a
 105 withFixture action (db, fix) =
 106   runPoolPQ (transactionally_ $ action fix) (pool db)
 107
 108 withoutFixture :: Actions schema a -> FixtureContext schema fix -> IO a
 109 withoutFixture action (db, _) =
 110   runPoolPQ (transactionally_ action) (pool db)
 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 schema a -> SpecWith (FixtureContext schema ())
 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 schema a) -> SpecWith (FixtureContext schema fix)
 121 itDBF msg action = it msg $ void . withFixture action
 122
 123 itDBF_ :: String -> Actions schema a -> SpecWith (FixtureContext schema 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 p => AlignedList (Migration p) schema0 schema
 141   -> Fixtures schema ()
 142   -> String
 143   -> SpecWith (FixtureContext schema ())
 144   -> Spec
 145 describeDB migrate fixture str =
 146   beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str
 147
 148 -- | Like `decribeDB`, but allow fixtures to pass
 149 -- | a result to all specs
 150 describeFixtures
 151   :: Migratory p => AlignedList (Migration p) schema0 schema
 152   -> Fixtures schema fix
 153   -> String
 154   -> SpecWith (FixtureContext schema fix)
 155   -> Spec
 156 describeFixtures migrate fixture str =
 157   beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate . fst) . describe str