sydtest-persistent 0.0.0.0 → 0.0.0.1
raw patch · 6 files changed
+113/−91 lines, 6 filesdep +bytestringdep +textdep +unliftiodep −monad-loggerdep −persistent-sqlitedep −persistent-template
Dependencies added: bytestring, text, unliftio
Dependencies removed: monad-logger, persistent-sqlite, persistent-template, sydtest-persistent
Files
- CHANGELOG.md +11/−0
- src/Test/Syd/Persistent.hs +93/−0
- sydtest-persistent.cabal +9/−27
- test/Spec.hs +0/−1
- test/Test/Syd/Persistent/Example.hs +0/−28
- test/Test/Syd/PersistentSpec.hs +0/−35
+ CHANGELOG.md view
@@ -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`.
src/Test/Syd/Persistent.hs view
@@ -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
sydtest-persistent.cabal view
@@ -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
− test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
− test/Test/Syd/Persistent/Example.hs
@@ -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-|]
− test/Test/Syd/PersistentSpec.hs
@@ -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)