{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Testing with an in-memory sqlite database using persistent-sqlite
module Test.Syd.Persistent
( runSqlPool,
runPersistentTest,
migrationRunner,
migrationsSucceedsSpecHelper,
)
where
import Control.Monad.Reader
import qualified Data.ByteString as SB
import Data.List
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Database.Persist.Sql
import Test.Syd
import UnliftIO
instance IsTest (SqlPersistM ()) where
type Arg1 (SqlPersistM ()) = ()
type Arg2 (SqlPersistM ()) = ConnectionPool
runTest func = runTest (\() -> func)
instance IsTest (outerArgs -> SqlPersistM ()) where
type Arg1 (outerArgs -> SqlPersistM ()) = outerArgs
type Arg2 (outerArgs -> SqlPersistM ()) = ConnectionPool
runTest func = runTest (\outerArgs pool -> runPersistentTest pool (func outerArgs))
-- | A flipped version of 'runSqlPool' to run your tests
runPersistentTest :: ConnectionPool -> SqlPersistM a -> IO a
runPersistentTest = flip runSqlPersistMPool
-- | Helper function to run a 'Migration' before/in a test suite that works accross versions of @persistent@.
#if MIN_VERSION_persistent(2,10,2)
migrationRunner :: MonadIO m => Migration -> ReaderT SqlBackend m ()
migrationRunner = void . runMigrationQuiet
#else
migrationRunner :: MonadIO m => Migration -> ReaderT SqlBackend m ()
migrationRunner = runMigration
#endif
-- | Test that the given migration succeeds, when applied to the current database.
--
-- This uses two tests:
--
-- 1. A golden test for the current migration.
-- 2. A test that first applies the golden migration, and then the current migration, tee see if that fails.
migrationsSucceedsSpecHelper ::
-- | Setupfunc for a ConnectionPool. This will be passed an empty migration
(Migration -> SetupFunc ConnectionPool) ->
FilePath ->
Migration ->
Spec
migrationsSucceedsSpecHelper connectionPoolSetupFunc migrationFile currentMigration =
let emptyMigration = pure ()
in setupAround (connectionPoolSetupFunc emptyMigration) $
doNotRandomiseExecutionOrder $
sequential $ do
descriptionPathHere <- getTestDescriptionPath
let migrationTestDescription = "Can automatically migrate from the previous database schema"
migrationTestPath = intercalate "." $ reverse $ migrationTestDescription : map T.unpack descriptionPathHere
helpTextInMigrationFile =
[ "ATTENTION CODE REVIEWER",
"If this file has been updated, please make sure to check",
"whether this test failed before that happened:",
show migrationTestPath,
"If this test failed beforehand, but this golden test has",
"been updated anyway, that means the current migration is",
"dangerous with respect to the current database."
]
renderStatements :: [Text] -> Text
renderStatements ss =
T.pack $
unlines $
concat
[ map ((<> ";") . T.unpack) ss,
[""],
map ("-- " <>) helpTextInMigrationFile
]
unrenderStatements :: Text -> [Text]
unrenderStatements =
filter (not . T.isPrefixOf "-- ")
. filter (not . T.null . T.strip)
. T.lines
it "Golden test for the current migrations" $ \pool ->
let helpText =
unlines
[ "\nIMPORTANT: Read this message if this test fails.",
"If this test fails, make check whether the next test has failed as well.",
"",
"That test is called ",
show migrationTestPath,
"",
"It passed: All is good, you can reset this golden file safely.",
"It failed: The database change you introduced will require manual intervention, proceed with caution."
]
gt = goldenTextFile migrationFile (runSqlPool (renderStatements <$> runMigrationQuiet currentMigration) pool)
in gt
{ goldenTestCompare = \actual expected ->
let addHelpContext a = Context a helpText
in addHelpContext <$> goldenTestCompare gt actual expected
}
it migrationTestDescription $ do
contents <- liftIO $ SB.readFile migrationFile
case TE.decodeUtf8' contents of
Left err -> liftIO $ expectationFailure $ show err
Right textContents -> do
let statements = unrenderStatements textContents
-- Set up the database with the old migrations
forM_ statements $ \statement ->
rawExecute statement [] :: SqlPersistM ()
-- Try to run the current migrations
errOrStatements <-
(Right <$> runMigrationQuiet currentMigration)
`catch` (\e -> pure $ Left (e :: PersistException)) ::
SqlPersistM (Either PersistException [Text])
case errOrStatements of
Right _ -> pure ()
Left err -> liftIO $ case err of
PersistError t -> expectationFailure $ T.unpack t
_ -> expectationFailure $ ppShow err