{-# 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
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 :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
     -> Arg2 (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
     -> IO ())
    -> IO ())
-> IO TestRunResult
runTest ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
func)

instance IsTest (outerArgs -> SqlPersistM ()) where
  type Arg1 (outerArgs -> SqlPersistM ()) = outerArgs
  type Arg2 (outerArgs -> SqlPersistM ()) = ConnectionPool
  runTest :: (outerArgs -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
-> TestRunSettings
-> ProgressReporter
-> ((Arg1
       (outerArgs -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
     -> Arg2
          (outerArgs -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
     -> IO ())
    -> IO ())
-> IO TestRunResult
runTest outerArgs -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\outerArgs
outerArgs ConnectionPool
pool -> forall a. ConnectionPool -> SqlPersistM a -> IO a
runPersistentTest ConnectionPool
pool (outerArgs -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
func outerArgs
outerArgs))

-- | A flipped version of 'runSqlPool' to run your tests
runPersistentTest :: ConnectionPool -> SqlPersistM a -> IO a
runPersistentTest :: forall a. ConnectionPool -> SqlPersistM a -> IO a
runPersistentTest = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall backend a.
BackendCompatible SqlBackend backend =>
ReaderT backend (NoLoggingT (ResourceT IO)) a
-> Pool backend -> IO a
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 :: forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m ()
migrationRunner = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m [Text]
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 :: (Migration -> SetupFunc ConnectionPool)
-> [Char] -> Migration -> Spec
migrationsSucceedsSpecHelper Migration -> SetupFunc ConnectionPool
connectionPoolSetupFunc [Char]
migrationFile Migration
currentMigration =
  let emptyMigration :: Migration
emptyMigration = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
   in forall inner (outers :: [*]) result any.
SetupFunc inner
-> TestDefM outers inner result -> TestDefM outers any result
setupAround (Migration -> SetupFunc ConnectionPool
connectionPoolSetupFunc Migration
emptyMigration) forall a b. (a -> b) -> a -> b
$
        forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
doNotRandomiseExecutionOrder forall a b. (a -> b) -> a -> b
$
          forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
sequential forall a b. (a -> b) -> a -> b
$ do
            [Text]
descriptionPathHere <- forall (outers :: [*]) inner. TestDefM outers inner [Text]
getTestDescriptionPath

            let migrationTestDescription :: [Char]
migrationTestDescription = [Char]
"Can automatically migrate from the previous database schema"
                migrationTestPath :: [Char]
migrationTestPath = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ [Char]
migrationTestDescription forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
descriptionPathHere

                helpTextInMigrationFile :: [[Char]]
helpTextInMigrationFile =
                  [ [Char]
"ATTENTION CODE REVIEWER",
                    [Char]
"If this file has been updated, please make sure to check",
                    [Char]
"whether this test failed before that happened:",
                    forall a. Show a => a -> [Char]
show [Char]
migrationTestPath,
                    [Char]
"If this test failed beforehand, but this golden test has",
                    [Char]
"been updated anyway, that means the current migration is",
                    [Char]
"dangerous with respect to the current database."
                  ]

                renderStatements :: [Text] -> Text
                renderStatements :: [Text] -> Text
renderStatements [Text]
ss =
                  [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$
                    [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$
                      forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                        [ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Semigroup a => a -> a -> a
<> [Char]
";") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) [Text]
ss,
                          [[Char]
""],
                          forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"-- " forall a. Semigroup a => a -> a -> a
<>) [[Char]]
helpTextInMigrationFile
                        ]
                unrenderStatements :: Text -> [Text]
                unrenderStatements :: Text -> [Text]
unrenderStatements =
                  forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Bool
T.isPrefixOf Text
"-- ")
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip)
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

            forall (outers :: [*]) inner test.
(HasCallStack, IsTest test, Arg1 test ~ (), Arg2 test ~ inner) =>
[Char] -> test -> TestDefM outers inner ()
it [Char]
"Golden test for the current migrations" forall a b. (a -> b) -> a -> b
$ \ConnectionPool
pool ->
              let helpText :: [Char]
helpText =
                    [[Char]] -> [Char]
unlines
                      [ [Char]
"\nIMPORTANT: Read this message if this test fails.",
                        [Char]
"If this test fails, make check whether the next test has failed as well.",
                        [Char]
"",
                        [Char]
"That test is called ",
                        forall a. Show a => a -> [Char]
show [Char]
migrationTestPath,
                        [Char]
"",
                        [Char]
"It passed: All is good, you can reset this golden file safely.",
                        [Char]
"It failed: The database change you introduced will require manual intervention, proceed with caution."
                      ]
                  gt :: GoldenTest Text
gt = [Char] -> IO Text -> GoldenTest Text
goldenTextFile [Char]
migrationFile (forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool ([Text] -> Text
renderStatements forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationQuiet Migration
currentMigration) ConnectionPool
pool)
               in GoldenTest Text
gt
                    { goldenTestCompare :: Text -> Text -> Maybe Assertion
goldenTestCompare = \Text
actual Text
expected ->
                        let addHelpContext :: Assertion -> Assertion
addHelpContext Assertion
a = Assertion -> [Char] -> Assertion
Context Assertion
a [Char]
helpText
                         in Assertion -> Assertion
addHelpContext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GoldenTest a -> a -> a -> Maybe Assertion
goldenTestCompare GoldenTest Text
gt Text
actual Text
expected
                    }

            forall (outers :: [*]) inner test.
(HasCallStack, IsTest test, Arg1 test ~ (), Arg2 test ~ inner) =>
[Char] -> test -> TestDefM outers inner ()
it [Char]
migrationTestDescription forall a b. (a -> b) -> a -> b
$ do
              ByteString
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
SB.readFile [Char]
migrationFile
              case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
contents of
                Left UnicodeException
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show UnicodeException
err
                Right Text
textContents -> do
                  let statements :: [Text]
statements = Text -> [Text]
unrenderStatements Text
textContents
                  -- Set up the database with the old migrations
                  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
statements forall a b. (a -> b) -> a -> b
$ \Text
statement ->
                    forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute Text
statement [] :: SqlPersistM ()
                  -- Try to run the current migrations
                  Either PersistException [Text]
errOrStatements <-
                    (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationQuiet Migration
currentMigration)
                      forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\PersistException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (PersistException
e :: PersistException)) ::
                      SqlPersistM (Either PersistException [Text])
                  case Either PersistException [Text]
errOrStatements of
                    Right [Text]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    Left PersistException
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case PersistException
err of
                      PersistError Text
t -> forall a. HasCallStack => [Char] -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t
                      PersistException
_ -> forall a. HasCallStack => [Char] -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
ppShow PersistException
err