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

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

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

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

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

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

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

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