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 TypeInType       #-}
  17 {-# LANGUAGE TypeOperators    #-}
  18 module Squeal.PostgreSQL.Hspec
  19 where
  20
  21 import           Control.Exception
  22 import           Control.Monad
  23 import           Control.Monad.Base     (liftBase)
  24 import qualified Data.ByteString.Char8  as BSC
  25 import qualified Database.Postgres.Temp as Temp
  26 import           Generics.SOP           (K)
  27 import           Squeal.PostgreSQL
  28 import           Squeal.PostgreSQL.Pool
  29 import           Test.Hspec
  30
  31 data TestDB a = TestDB
  32   { tempDB :: Temp.DB
  33   -- ^ Handle for temporary @postgres@ process
  34   , pool   :: Pool a
  35   -- ^ Pool of 50 connections to the temporary @postgres@
  36   }
  37
  38 type Fixtures schema = (Pool (K Connection schema) -> IO ())
  39 type Actions schema a = PoolPQ schema IO a
  40 type SquealContext schema = TestDB (K Connection schema)
  41
  42 -- | Start a temporary @postgres@ process and create a pool of connections to it
  43 setupDB
  44   :: AlignedList (Migration (Terminally PQ IO)) schema0 schema
  45   -> Fixtures schema
  46   -> IO (SquealContext schema)
  47 setupDB migration fixtures = do
  48   tempDB <- either throwIO return =<< Temp.startAndLogToTmp []
  49   let connectionString = BSC.pack (Temp.connectionString tempDB)
  50   putStrLn $ Temp.connectionString tempDB
  51   let singleStripe = 1
  52       keepConnectionForOneHour = 3600
  53       poolSizeOfFifty = 50
  54   pool <- createConnectionPool
  55      connectionString
  56      singleStripe
  57      keepConnectionForOneHour
  58      poolSizeOfFifty
  59   withConnection connectionString (migrateUp migration)
  60   fixtures pool
  61   pure TestDB {..}
  62
  63 -- | Drop all the connections and shutdown the @postgres@ process
  64 teardownDB :: TestDB a -> IO ()
  65 teardownDB TestDB {..} = do
  66   destroyAllResources pool
  67   void $ Temp.stop tempDB
  68
  69 -- | Run an 'IO' action with a connection from the pool
  70 withPool :: TestDB (K Connection schema) -> Actions schema a -> IO a
  71 withPool testDB = liftBase . flip runPoolPQ (pool testDB)
  72
  73 -- | Run an 'DB' transaction, using 'transactionally_'
  74 withDB :: Actions schema a -> TestDB (K Connection schema) -> IO a
  75 withDB action testDB =
  76   runPoolPQ (transactionally_ action) (pool testDB)
  77
  78 -- | Flipped version of 'withDB'
  79 runDB :: TestDB (K Connection schema) -> Actions schema a -> IO a
  80 runDB = flip withDB
  81
  82 -- | Helper for writing tests. Wrapper around 'it' that uses the passed
  83 --   in 'TestDB' to run a db transaction automatically for the test.
  84 itDB :: String -> Actions schema a -> SpecWith (TestDB (K Connection schema))
  85 itDB msg action = it msg $ void . withDB action
  86
  87 -- | Wraps 'describe' with a
  88 --
  89 -- @
  90 --   'beforeAll' ('setupDB' migrate)
  91 -- @
  92 --
  93 -- hook for creating a db and a
  94 --
  95 -- @
  96 --   'afterAll' 'teardownDB'
  97 -- @
  98 --
  99 -- hook for stopping a db.
 100 describeDB
 101   :: AlignedList (Migration (Terminally PQ IO)) schema0 schema
 102   -> Fixtures schema
 103   -> String
 104   -> SpecWith (SquealContext schema)
 105   -> Spec
 106 describeDB migrate fixture str =
 107   beforeAll (setupDB migrate fixture) . afterAll teardownDB . describe str