diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog + +## [0.0.0.1] - 2022-05-05 + +### Added + +* `migrationsSucceedsSpecHelper` + +## [0.0.0.0] - 2021-06-19 + +First release with functions from early versions of `sydtest-persistent-sqlite` and `sydtest-persistent-postgresql`. diff --git a/src/Test/Syd/Persistent.hs b/src/Test/Syd/Persistent.hs --- a/src/Test/Syd/Persistent.hs +++ b/src/Test/Syd/Persistent.hs @@ -9,12 +9,19 @@ ( 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 ()) = () @@ -38,3 +45,89 @@ 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 diff --git a/sydtest-persistent.cabal b/sydtest-persistent.cabal --- a/sydtest-persistent.cabal +++ b/sydtest-persistent.cabal @@ -1,21 +1,24 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack name: sydtest-persistent -version: 0.0.0.0 +version: 0.0.0.1 synopsis: A persistent companion library for sydtest category: Testing homepage: https://github.com/NorfairKing/sydtest#readme bug-reports: https://github.com/NorfairKing/sydtest/issues author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu -copyright: Copyright (c) 2021 Tom Sydney Kerckhove +copyright: Copyright (c) 2021-2022 Tom Sydney Kerckhove license: OtherLicense license-file: LICENSE.md build-type: Simple +extra-source-files: + LICENSE.md + CHANGELOG.md source-repository head type: git @@ -30,31 +33,10 @@ src build-depends: base >=4.7 && <5 - , monad-logger + , bytestring , mtl , persistent - , persistent-template , sydtest - default-language: Haskell2010 - -test-suite sydtest-persistent-sqlite-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Test.Syd.Persistent.Example - Test.Syd.PersistentSpec - Paths_sydtest_persistent - hs-source-dirs: - test - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-tool-depends: - sydtest-discover:sydtest-discover - build-depends: - base >=4.7 && <5 - , monad-logger - , persistent - , persistent-sqlite - , persistent-template - , sydtest - , sydtest-persistent + , text + , unliftio default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/Test/Syd/Persistent/Example.hs b/test/Test/Syd/Persistent/Example.hs deleted file mode 100644 --- a/test/Test/Syd/Persistent/Example.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Test.Syd.Persistent.Example where - -import Database.Persist.Sql -import Database.Persist.TH - -share - [mkPersist sqlSettings, mkMigrate "migrateExample"] - [persistLowerCase| -Person - name String - age Int Maybe - deriving Show Eq -|] diff --git a/test/Test/Syd/PersistentSpec.hs b/test/Test/Syd/PersistentSpec.hs deleted file mode 100644 --- a/test/Test/Syd/PersistentSpec.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Syd.PersistentSpec (spec) where - -import Control.Monad.Logger -import Database.Persist -import Database.Persist.Sql -import Database.Persist.Sqlite -import Test.Syd -import Test.Syd.Persistent -import Test.Syd.Persistent.Example - -spec :: Spec -spec = do - let persistSpec :: SpecWith ConnectionPool -> Spec - persistSpec = setupAround $ - SetupFunc $ \takeConnectionPool -> - runNoLoggingT $ - withSqlitePool ":memory:" 1 $ \pool -> do - _ <- flip runSqlPool pool $ migrationRunner migrateExample - liftIO $ takeConnectionPool pool - - persistSpec $ do - it "can write and read this example person" $ \pool -> runPersistentTest pool $ do - let p = Person {personName = "John Doe", personAge = Just 21} - i <- insert p - mp <- get i - liftIO $ mp `shouldBe` Just p - describe "shared data" $ do - it "can write this example person" $ \pool -> runPersistentTest pool $ do - let p = Person {personName = "John Doe", personAge = Just 21} - insert_ p - it "cannot read anything that has not been written yet" $ \pool -> runPersistentTest pool $ do - mp <- get (toSqlKey 0) - liftIO $ mp `shouldBe` (Nothing :: Maybe Person)