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 = (Pool (K Connection schema) -> IO ())
  43 type Actions schema a = PoolPQ schema IO a
  44 type SquealContext schema = TestDB (K Connection schema)
  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   :: AlignedList (Migration (Terminally PQ IO)) schema0 schema
  63   -> Fixtures schema
  64   -> IO (SquealContext schema)
  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   fixtures pool
  78   pure TestDB {..}
  79
  80 -- | Drop all the connections and shutdown the @postgres@ process
  81 teardownDB
  82   :: AlignedList (Migration (Terminally PQ IO)) schema0 schema
  83   -> TestDB a
  84   -> IO ()
  85 teardownDB migration TestDB {..} = do
  86   withConnection connectionString (migrateDown migration)
  87   destroyAllResources pool
  88   maybe (pure ()) (void . Temp.stop) tempDB
  89
  90 -- | Run an 'IO' action with a connection from the pool
  91 withPool :: TestDB (K Connection schema) -> Actions schema a -> IO a
  92 withPool testDB = liftBase . flip runPoolPQ (pool testDB)
  93
  94 -- | Run an 'DB' transaction, using 'transactionally_'
  95 withDB :: Actions schema a -> TestDB (K Connection schema) -> IO a
  96 withDB action testDB =
  97   runPoolPQ (transactionally_ action) (pool testDB)
  98
  99 -- | Flipped version of 'withDB'
 100 runDB :: TestDB (K Connection schema) -> Actions schema a -> IO a
 101 runDB = flip withDB
 102
 103 -- | Helper for writing tests. Wrapper around 'it' that uses the passed
 104 --   in 'TestDB' to run a db transaction automatically for the test.
 105 itDB :: String -> Actions schema a -> SpecWith (TestDB (K Connection schema))
 106 itDB msg action = it msg $ void . withDB action
 107
 108 -- | Wraps 'describe' with a
 109 --
 110 -- @
 111 --   'beforeAll' ('setupDB' migrate)
 112 -- @
 113 --
 114 -- hook for creating a db and a
 115 --
 116 -- @
 117 --   'afterAll' 'teardownDB'
 118 -- @
 119 --
 120 -- hook for stopping a db.
 121 describeDB
 122   :: AlignedList (Migration (Terminally PQ IO)) schema0 schema
 123   -> Fixtures schema
 124   -> String
 125   -> SpecWith (SquealContext schema)
 126   -> Spec
 127 describeDB migrate fixture str =
 128   beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate) . describe str