{-|
Helpers for creating database tests with hspec and pg-transact

@hspec-pg-transact@ utilizes @tmp-postgres@ to automatically and connect to a temporary instance of @postgres@ on a random port.

 @
  'describeDB' migrate "Query” $
    itDB "work" $ do
      'execute_' [sql|
        INSERT INTO things
        VALUES (‘me’) |]
      'query_' [sql|
        SELECT name
         FROM things |]
        `shouldReturn` [Only "me"]
 @

In the example above 'describeDB' wraps 'describe' with a 'beforeAll' hook for creating a db and a 'afterAll' hook for stopping a db.
.
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.

The libary also provides a few other functions for more fine grained control over running transactions in tests.

-}

module Test.Hspec.DB where

import           Control.Monad
import           Data.Pool
import           Database.PostgreSQL.Simple
import           Database.PostgreSQL.Transact
import qualified Database.Postgres.Temp       as Temp
import           Test.Hspec

data TestDB = TestDB
  { TestDB -> DB
tempDB :: Temp.DB
  -- ^ Handle for temporary @postgres@ process
  , TestDB -> Pool Connection
pool   :: Pool Connection
  -- ^ Pool of 50 connections to the temporary @postgres@
  }

-- | Start a temporary @postgres@ process and create a pool of connections to it
setupDB :: (Connection -> IO ()) -> IO (Either Temp.StartError TestDB)
setupDB :: (Connection -> IO ()) -> IO (Either StartError TestDB)
setupDB = Config -> (Connection -> IO ()) -> IO (Either StartError TestDB)
setupDBWithConfig Config
Temp.defaultConfig

-- | Start a temporary @postgres@ process using the provided configuration
setupDBWithConfig :: Temp.Config
  -> (Connection -> IO ())
  -> IO (Either Temp.StartError TestDB)
setupDBWithConfig :: Config -> (Connection -> IO ()) -> IO (Either StartError TestDB)
setupDBWithConfig Config
c Connection -> IO ()
f =
  (DB -> IO TestDB)
-> Either StartError DB -> IO (Either StartError TestDB)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Connection -> IO ()) -> DB -> IO TestDB
wrapCallback Connection -> IO ()
f) (Either StartError DB -> IO (Either StartError TestDB))
-> IO (Either StartError DB) -> IO (Either StartError TestDB)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Config -> IO (Either StartError DB)
Temp.startConfig Config
c

wrapCallback :: (Connection -> IO ()) -> Temp.DB -> IO TestDB
wrapCallback :: (Connection -> IO ()) -> DB -> IO TestDB
wrapCallback Connection -> IO ()
f DB
d = do
  Pool Connection
p <- IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool Connection)
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
createPool
    (ByteString -> IO Connection
connectPostgreSQL (ByteString -> IO Connection) -> ByteString -> IO Connection
forall a b. (a -> b) -> a -> b
$ DB -> ByteString
Temp.toConnectionString DB
d)
    Connection -> IO ()
close
    Int
1
    NominalDiffTime
100000000
    Int
50
  Pool Connection -> (Connection -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource Pool Connection
p Connection -> IO ()
f
  TestDB -> IO TestDB
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestDB -> IO TestDB) -> TestDB -> IO TestDB
forall a b. (a -> b) -> a -> b
$ DB -> Pool Connection -> TestDB
TestDB DB
d Pool Connection
p

-- | Drop all the connections and shutdown the @postgres@ process
teardownDB :: TestDB -> IO ()
teardownDB :: TestDB -> IO ()
teardownDB (TestDB DB
d Pool Connection
p) = do
  Pool Connection -> IO ()
forall a. Pool a -> IO ()
destroyAllResources Pool Connection
p
  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DB -> IO ()
Temp.stop DB
d

-- | Run an 'IO' action with a connection from the pool
withPool :: TestDB -> (Connection -> IO a) -> IO a
withPool :: TestDB -> (Connection -> IO a) -> IO a
withPool TestDB
testDB = Pool Connection -> (Connection -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource (TestDB -> Pool Connection
pool TestDB
testDB)

-- | Run an 'DB' transaction. Uses 'runDBTSerializable'.
withDB :: DB a -> TestDB -> IO a
withDB :: DB a -> TestDB -> IO a
withDB DB a
action TestDB
testDB =
  Pool Connection -> (Connection -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource (TestDB -> Pool Connection
pool TestDB
testDB) (DB a -> Connection -> IO a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
DBT m a -> Connection -> m a
runDBTSerializable DB a
action)

-- | Flipped version of 'withDB'
runDB :: TestDB -> DB a -> IO a
runDB :: TestDB -> DB a -> IO a
runDB = (DB a -> TestDB -> IO a) -> TestDB -> DB a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip DB a -> TestDB -> IO a
forall a. DB a -> TestDB -> IO a
withDB

-- | Helper for writing tests. Wrapper around 'it' that uses the passed
--   in 'TestDB' to run a db transaction automatically for the test.
itDB :: String -> DB a -> SpecWith TestDB
itDB :: String -> DB a -> SpecWith TestDB
itDB String
msg DB a
action = String -> (TestDB -> IO ()) -> SpecWith (Arg (TestDB -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
msg ((TestDB -> IO ()) -> SpecWith (Arg (TestDB -> IO ())))
-> (TestDB -> IO ()) -> SpecWith (Arg (TestDB -> IO ()))
forall a b. (a -> b) -> a -> b
$ IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> (TestDB -> IO a) -> TestDB -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DB a -> TestDB -> IO a
forall a. DB a -> TestDB -> IO a
withDB DB a
action

-- | Wraps 'describeDBWithConfig' using the default configuration
describeDB :: (Connection -> IO ()) -> String -> SpecWith TestDB -> Spec
describeDB :: (Connection -> IO ()) -> String -> SpecWith TestDB -> Spec
describeDB = Config
-> (Connection -> IO ()) -> String -> SpecWith TestDB -> Spec
describeDBWithConfig Config
Temp.defaultConfig

-- | Wraps 'describe' with a
--
-- @
--   'beforeAll' ('setupDB' migrate)
-- @
--
-- hook for creating a db and a
--
-- @
--   'afterAll' 'teardownDB'
-- @
--
-- hook for stopping a db.
describeDBWithConfig :: Temp.Config -> (Connection -> IO ()) -> String -> SpecWith TestDB -> Spec
describeDBWithConfig :: Config
-> (Connection -> IO ()) -> String -> SpecWith TestDB -> Spec
describeDBWithConfig Config
c Connection -> IO ()
f String
s =
  IO TestDB -> SpecWith TestDB -> Spec
forall a. IO a -> SpecWith a -> Spec
beforeAll (Either StartError TestDB -> IO TestDB
catch (Either StartError TestDB -> IO TestDB)
-> IO (Either StartError TestDB) -> IO TestDB
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Config -> (Connection -> IO ()) -> IO (Either StartError TestDB)
setupDBWithConfig Config
c Connection -> IO ()
f) (SpecWith TestDB -> Spec)
-> (SpecWith TestDB -> SpecWith TestDB) -> SpecWith TestDB -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestDB -> IO ()) -> SpecWith TestDB -> SpecWith TestDB
forall a. HasCallStack => ActionWith a -> SpecWith a -> SpecWith a
afterAll TestDB -> IO ()
teardownDB (SpecWith TestDB -> SpecWith TestDB)
-> (SpecWith TestDB -> SpecWith TestDB)
-> SpecWith TestDB
-> SpecWith TestDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SpecWith TestDB -> SpecWith TestDB
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
s
  where
    catch :: Either Temp.StartError TestDB -> IO TestDB
    catch :: Either StartError TestDB -> IO TestDB
catch Either StartError TestDB
r = case Either StartError TestDB
r of
      Left StartError
x   -> String -> IO TestDB
forall a. HasCallStack => String -> a
error (StartError -> String
forall a. Show a => a -> String
show StartError
x)
      Right TestDB
db -> TestDB -> IO TestDB
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestDB
db