{-# 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 = (() -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (() -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
     -> Arg2 (() -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
     -> IO ())
    -> IO ())
-> IO TestRunResult
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 = (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
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) () -> IO ()
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 = (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 :: forall (m :: * -> *).
MonadIO m =>
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)
-> [Char] -> Migration -> Spec
migrationsSucceedsSpecHelper Migration -> SetupFunc ConnectionPool
connectionPoolSetupFunc [Char]
migrationFile Migration
currentMigration =
  let emptyMigration :: Migration
emptyMigration = () -> Migration
forall a.
a
-> WriterT
     [Text] (WriterT CautiousMigration (ReaderT SqlBackend IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
   in SetupFunc ConnectionPool -> TestDefM '[] ConnectionPool () -> Spec
forall inner (outers :: [*]) result any.
SetupFunc inner
-> TestDefM outers inner result -> TestDefM outers any 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 :: [Char]
migrationTestDescription = [Char]
"Can automatically migrate from the previous database schema"
                migrationTestPath :: [Char]
migrationTestPath = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char]
migrationTestDescription [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Text -> [Char]) -> [Text] -> [[Char]]
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:",
                    [Char] -> [Char]
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 ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
                    [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
                      [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                        [ (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
";") ([Char] -> [Char]) -> (Text -> [Char]) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) [Text]
ss,
                          [[Char]
""],
                          ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"-- " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>) [[Char]]
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

            [Char]
-> (ConnectionPool -> GoldenTest Text)
-> TestDefM '[] ConnectionPool ()
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" ((ConnectionPool -> GoldenTest Text)
 -> TestDefM '[] ConnectionPool ())
-> (ConnectionPool -> GoldenTest Text)
-> TestDefM '[] ConnectionPool ()
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 ",
                        [Char] -> [Char]
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 (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
actual Text
expected ->
                        let addHelpContext :: Assertion -> Assertion
addHelpContext Assertion
a = Assertion -> [Char] -> Assertion
Context Assertion
a [Char]
helpText
                         in (Assertion -> Assertion) -> Maybe Assertion -> Maybe Assertion
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Assertion -> Assertion
addHelpContext (Maybe Assertion -> Maybe Assertion)
-> IO (Maybe Assertion) -> IO (Maybe Assertion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GoldenTest Text -> Text -> Text -> IO (Maybe Assertion)
forall a. GoldenTest a -> a -> a -> IO (Maybe Assertion)
goldenTestCompare GoldenTest Text
gt Text
actual Text
expected
                    }

            [Char]
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
-> TestDefM '[] ConnectionPool ()
forall (outers :: [*]) inner test.
(HasCallStack, IsTest test, Arg1 test ~ (), Arg2 test ~ inner) =>
[Char] -> test -> TestDefM outers inner ()
it [Char]
migrationTestDescription (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
 -> TestDefM '[] ConnectionPool ())
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
-> TestDefM '[] ConnectionPool ()
forall a b. (a -> b) -> a -> b
$ do
              ByteString
contents <- IO ByteString
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ByteString
forall a. IO a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
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
$ [Char] -> IO ByteString
SB.readFile [Char]
migrationFile
              case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
contents of
                Left UnicodeException
err -> IO () -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
forall a. IO a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
-> IO () -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
expectationFailure ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ UnicodeException -> [Char]
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
                  [Text]
-> (Text -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
statements ((Text -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
 -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
-> (Text -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
forall a b. (a -> b) -> a -> b
$ \Text
statement ->
                    Text
-> [PersistValue]
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
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 a. a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
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]
_ -> () -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
forall a. a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    Left PersistException
err -> IO () -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
forall a. IO a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
-> IO () -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
forall a b. (a -> b) -> a -> b
$ case PersistException
err of
                      PersistError Text
t -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
expectationFailure ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t
                      PersistException
_ -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
expectationFailure ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ PersistException -> [Char]
forall a. Show a => a -> [Char]
ppShow PersistException
err