From dd35032c658cf4136e94b18c87656a611931b0ed Mon Sep 17 00:00:00 2001
From: Raveline <eraveline@gmail.com>
Date: Fri, 3 May 2019 11:43:58 +0200
Subject: Support fixed databases

---
 src/Squeal/PostgreSQL/Hspec.hs | 39 ++++++++++++++++++++++++++++++---------
 1 file changed, 30 insertions(+), 9 deletions(-)

diff --git a/src/Squeal/PostgreSQL/Hspec.hs b/src/Squeal/PostgreSQL/Hspec.hs
index 3cd886b..d065048 100644
--- a/src/Squeal/PostgreSQL/Hspec.hs
+++ b/src/Squeal/PostgreSQL/Hspec.hs
@@ -13,6 +13,7 @@ The libary also provides a few other functions for more fine grained control ove
 {-# LANGUAGE MonoLocalBinds   #-}
 {-# LANGUAGE RankNTypes       #-}
 {-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE TupleSections    #-}
 {-# LANGUAGE TypeInType       #-}
 {-# LANGUAGE TypeOperators    #-}
 module Squeal.PostgreSQL.Hspec
@@ -21,33 +22,49 @@ where
 import           Control.Exception
 import           Control.Monad
 import           Control.Monad.Base     (liftBase)
+import           Data.ByteString        (ByteString)
 import qualified Data.ByteString.Char8  as BSC
 import qualified Database.Postgres.Temp as Temp
 import           Generics.SOP           (K)
 import           Squeal.PostgreSQL
 import           Squeal.PostgreSQL.Pool
+import           System.Environment     (lookupEnv)
 import           Test.Hspec
 
 data TestDB a = TestDB
-  { tempDB :: Temp.DB
+  { tempDB           :: Maybe Temp.DB
   -- ^ Handle for temporary @postgres@ process
-  , pool   :: Pool a
+  , pool             :: Pool a
   -- ^ Pool of 50 connections to the temporary @postgres@
+  , connectionString :: ByteString
   }
 
 type Fixtures schema = (Pool (K Connection schema) -> IO ())
 type Actions schema a = PoolPQ schema IO a
 type SquealContext schema = TestDB (K Connection schema)
 
+testDBEnv :: String
+testDBEnv = "TEST_DB_CONNECTION_STRING"
+
+getOrCreateConnectionString :: IO (ByteString, Maybe Temp.DB)
+getOrCreateConnectionString = do
+  hasConnectionString <- lookupEnv testDBEnv
+  maybe createTempDB (pure . (, Nothing) . BSC.pack) hasConnectionString
+
+createTempDB :: IO (ByteString, Maybe Temp.DB)
+createTempDB = do
+  tempDB <- either throwIO return =<< Temp.startAndLogToTmp []
+  let connectionString = BSC.pack (Temp.connectionString tempDB)
+  pure (connectionString, Just tempDB)
+
 -- | Start a temporary @postgres@ process and create a pool of connections to it
 setupDB
   :: AlignedList (Migration (Terminally PQ IO)) schema0 schema
   -> Fixtures schema
   -> IO (SquealContext schema)
 setupDB migration fixtures = do
-  tempDB <- either throwIO return =<< Temp.startAndLogToTmp []
-  let connectionString = BSC.pack (Temp.connectionString tempDB)
-  putStrLn $ Temp.connectionString tempDB
+  (connectionString, tempDB) <- getOrCreateConnectionString
+  BSC.putStrLn connectionString
   let singleStripe = 1
       keepConnectionForOneHour = 3600
       poolSizeOfFifty = 50
@@ -61,10 +78,14 @@ setupDB migration fixtures = do
   pure TestDB {..}
 
 -- | Drop all the connections and shutdown the @postgres@ process
-teardownDB :: TestDB a -> IO ()
-teardownDB TestDB {..} = do
+teardownDB
+  :: AlignedList (Migration (Terminally PQ IO)) schema0 schema
+  -> TestDB a
+  -> IO ()
+teardownDB migration TestDB {..} = do
+  withConnection connectionString (migrateDown migration)
   destroyAllResources pool
-  void $ Temp.stop tempDB
+  maybe (pure ()) (void . Temp.stop) tempDB
 
 -- | Run an 'IO' action with a connection from the pool
 withPool :: TestDB (K Connection schema) -> Actions schema a -> IO a
@@ -104,4 +125,4 @@ describeDB
   -> SpecWith (SquealContext schema)
   -> Spec
 describeDB migrate fixture str =
-  beforeAll (setupDB migrate fixture) . afterAll teardownDB . describe str
+  beforeAll (setupDB migrate fixture) . afterAll (teardownDB migrate) . describe str
-- 
cgit v1.2.3