sydtest-persistent-postgresql 0.2.0.3 → 0.3.0.0
raw patch · 5 files changed
+255/−28 lines, 5 filesdep +postgres-optionsdep +postgresql-simpledep +random
Dependencies added: postgres-options, postgresql-simple, random, text
Files
- CHANGELOG.md +7/−0
- src/Test/Syd/Persistent/Postgresql.hs +238/−21
- sydtest-persistent-postgresql.cabal +6/−2
- test/Test/Syd/Persistent/PostgresqlSpec.hs +3/−4
- test_resources/migration.sql +1/−1
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Changelog +## [0.3.0.0] - 2025-12-26++### Changed++* Complete overhaul: Tests now run with their own database based on a template+ database instead of their own entire postgres server.+ ## [0.2.0.3] - 2023-10-09 ### Added
src/Test/Syd/Persistent/Postgresql.hs view
@@ -1,24 +1,195 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-} -- | Testing with a temporary postgresql database using persistent-postgresql module Test.Syd.Persistent.Postgresql ( persistPostgresqlSpec,- withConnectionPool,- connectionPoolSetupFunc,- runSqlPool,+ persistPostgresqlAdminSpec,+ persistPostgresqlDatabaseSpec, runPostgresqlTest, postgresqlMigrationSucceedsSpec,+ connectionPoolSetupFunc,+ TemplateDB, ) where +import Control.Exception+import Control.Monad import Control.Monad.Logger import Control.Monad.Reader+import Data.Int+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text import Database.Persist.Postgresql+import qualified Database.PostgreSQL.Simple as PostgreSQL+import qualified Database.PostgreSQL.Simple.Options as Options+import qualified Database.PostgreSQL.Simple.Options as Postgres import Database.Postgres.Temp as Temp+import System.Environment+import System.Random import Test.Syd import Test.Syd.Persistent +adminDBSetupFunc :: SetupFunc Temp.DB+adminDBSetupFunc = SetupFunc $ \takeTempDB -> do+ -- Clear PostgreSQL environment variables that might interfere with tmp-postgres+ unsetEnv "PGHOST"+ unsetEnv "PGPORT"+ unsetEnv "PGDATABASE"+ unsetEnv "PGUSER"+ unsetEnv "PGPASSWORD"+ unsetEnv "PGDATA"+ errOrRes <- Temp.withConfig adminConfig takeTempDB+ case errOrRes of+ Left err -> liftIO $ expectationFailure $ show err+ Right r -> pure r++adminConfig :: Temp.Config+adminConfig =+ Temp.defaultConfig+ { Temp.createDbConfig = Temp.Zlich+ }++dbConnectionOptionsPoolSetupFunc :: Postgres.Options -> SetupFunc ConnectionPool+dbConnectionOptionsPoolSetupFunc options =+ SetupFunc $ \takeConnectionPool -> do+ runNoLoggingT $ do+ -- We use a fixed (small) number of connections to avoid overwhelming+ -- the temporary database server that's being called from multiple+ -- tests.+ -- But not 1 to avoid hiding failures that would have come from using+ -- multiple connections in the same test.+ withPostgresqlPool (Options.toConnectionString options) 3 $ \pool -> do+ liftIO $ takeConnectionPool pool++tempUserSetupFunc :: Temp.DB -> SetupFunc (Text, Text)+tempUserSetupFunc db =+ let createUser =+ withAdminConn db $ \conn -> do+ testuser <- genName "user"+ testpassword <- genName "password"+ _ <-+ executeWithLoudFailures+ conn+ ( "CREATE USER "+ <> fromString (Text.unpack testuser)+ <> " WITH PASSWORD ?;"+ )+ (PostgreSQL.Only testpassword)+ pure (testuser, testpassword)+ deleteUser (testuser, _) =+ withAdminConn db $ \conn -> do+ _ <-+ executeWithLoudFailures+ conn+ ( "DROP USER "+ <> fromString (Text.unpack testuser)+ <> ";"+ )+ ()+ pure ()+ in SetupFunc $ bracket createUser deleteUser++tempNewDatabaseSetupFunc :: Temp.DB -> Text -> SetupFunc Text+tempNewDatabaseSetupFunc db owner =+ let createDB = do+ testdb <- genName "template_db"+ withAdminConn db $ \conn -> do+ _ <-+ executeWithLoudFailures+ conn+ ( "CREATE DATABASE "+ <> fromString (Text.unpack testdb)+ <> " OWNER "+ <> fromString (Text.unpack owner)+ <> ";"+ )+ ()+ pure testdb+ deleteDB testdb =+ withAdminConn db $ \conn -> do+ _ <-+ executeWithLoudFailures+ conn+ ( "DROP DATABASE "+ <> fromString (Text.unpack testdb)+ <> " WITH (FORCE);"+ )+ ()+ pure ()+ in SetupFunc $ bracket createDB deleteDB++tempCopiedDatabaseSetupFunc ::+ Temp.DB ->+ Text ->+ Text ->+ SetupFunc Text+tempCopiedDatabaseSetupFunc+ db+ testuser+ templatedb =+ let createDB = do+ testdb <- genName "test_db"+ withAdminConn db $ \conn -> do+ _ <-+ executeWithLoudFailures+ conn+ ( "CREATE DATABASE "+ <> fromString (Text.unpack testdb)+ <> " OWNER "+ <> fromString (Text.unpack testuser)+ <> " TEMPLATE "+ <> fromString (Text.unpack templatedb)+ <> ";"+ )+ ()++ pure ()+ pure testdb+ deleteDB testdb =+ withAdminConn db $ \conn -> do+ _ <-+ executeWithLoudFailures+ conn+ ( "DROP DATABASE "+ <> fromString (Text.unpack testdb)+ <> " WITH (FORCE);"+ )+ ()+ pure ()+ in SetupFunc $ bracket createDB deleteDB++withAdminConn :: Temp.DB -> (PostgreSQL.Connection -> IO a) -> IO a+withAdminConn db =+ bracket+ (PostgreSQL.connectPostgreSQL (toConnectionString db))+ PostgreSQL.close++migrateTempDBSetupFunc :: Temp.DB -> Text -> Text -> Text -> Migration -> SetupFunc ()+migrateTempDBSetupFunc db testuser testpassword testdb migration =+ SetupFunc $ \takeUnit -> do+ let options =+ (toConnectionOptions db)+ { Postgres.user = pure (Text.unpack testuser),+ Postgres.password = pure (Text.unpack testpassword),+ Postgres.dbname = pure (Text.unpack testdb)+ }+ runNoLoggingT $ do+ withPostgresqlPool (Options.toConnectionString options) 1 $ \pool -> do+ runSqlPool (migrationRunner migration) pool+ takeUnit ()++genName :: String -> IO Text+genName prefix = do+ -- This is put into a query without escaping so it must be+ -- alphanumeric+ randomPiece <- replicateM 8 $ randomRIO ('a', 'z')+ pure $ Text.pack $ prefix <> "_" <> randomPiece+ -- | Declare a test suite that uses a database connection. -- -- Example usage@@ -45,25 +216,51 @@ -- > liftIO $ mp `shouldBe` Just p -- -- This sets up the database connection around every test, so state is not preserved accross tests.-persistPostgresqlSpec :: Migration -> SpecWith ConnectionPool -> SpecWith a-persistPostgresqlSpec migration = aroundWith $ \func _ -> withConnectionPool migration func+persistPostgresqlSpec ::+ Migration ->+ TestDef (TemplateDB ': outers) ConnectionPool ->+ TestDef outers a+persistPostgresqlSpec migration =+ persistPostgresqlAdminSpec migration+ . persistPostgresqlDatabaseSpec --- | Set up a postgresql connection and migrate it to run the given function.-withConnectionPool :: Migration -> (ConnectionPool -> IO r) -> IO r-withConnectionPool migration func = unSetupFunc (connectionPoolSetupFunc migration) func+type TemplateDB = (Temp.DB, (Text, Text, Text)) -- (db, (templateuser, templatedb)) --- | The 'SetupFunc' version of 'withConnectionPool'.-connectionPoolSetupFunc :: Migration -> SetupFunc ConnectionPool-connectionPoolSetupFunc migration = SetupFunc $ \takeConnectionPool -> do- errOrRes <- Temp.with $ \db ->- runNoLoggingT $- withPostgresqlPool (toConnectionString db) 1 $ \pool -> do- _ <- flip runSqlPool pool $ migrationRunner migration- liftIO $ takeConnectionPool pool- case errOrRes of- Left err -> liftIO $ expectationFailure $ show err- Right r -> pure r+persistPostgresqlAdminSpec ::+ Migration ->+ TestDef (TemplateDB ': outers) a ->+ TestDef outers a+persistPostgresqlAdminSpec migration =+ setupAroundAll $ do+ db <- adminDBSetupFunc+ (templateuser, templatepassword) <- tempUserSetupFunc db+ templatedb <- tempNewDatabaseSetupFunc db templateuser+ migrateTempDBSetupFunc db templateuser templatepassword templatedb migration+ pure (db, (templateuser, templatepassword, templatedb)) +persistPostgresqlDatabaseSpec :: (HContains outers TemplateDB) => TestDef outers ConnectionPool -> TestDef outers a+persistPostgresqlDatabaseSpec =+ setupAroundWith' $ \templatedb _ ->+ connectionPoolSetupFunc templatedb++-- | A 'SetupFunc' that provides a 'ConnectionPool' to a temporary database+connectionPoolSetupFunc ::+ TemplateDB ->+ SetupFunc ConnectionPool+connectionPoolSetupFunc (db, (testuser, testpassword, templatedb)) = do+ testdb <-+ tempCopiedDatabaseSetupFunc+ db+ testuser+ templatedb+ let options =+ (toConnectionOptions db)+ { Postgres.user = pure (Text.unpack testuser),+ Postgres.password = pure (Text.unpack testpassword),+ Postgres.dbname = pure (Text.unpack testdb)+ }+ dbConnectionOptionsPoolSetupFunc options+ -- | A flipped version of 'runSqlPool' to run your tests runPostgresqlTest :: ConnectionPool -> SqlPersistM a -> IO a runPostgresqlTest = runPersistentTest@@ -71,5 +268,25 @@ -- | Test that the given migration succeeds, when applied to the current database. -- -- See 'Test.Syd.Persistent.migrationsSucceedsSpec" for details.-postgresqlMigrationSucceedsSpec :: FilePath -> Migration -> Spec-postgresqlMigrationSucceedsSpec = migrationsSucceedsSpecHelper connectionPoolSetupFunc+postgresqlMigrationSucceedsSpec :: FilePath -> Migration -> TestDef outers void+postgresqlMigrationSucceedsSpec fp migration =+ persistPostgresqlSpec (pure ()) $+ migrationsSucceedsSpecHelper fp migration++executeWithLoudFailures ::+ (PostgreSQL.ToRow a) =>+ PostgreSQL.Connection ->+ PostgreSQL.Query ->+ a ->+ IO Int64+executeWithLoudFailures conn query args =+ PostgreSQL.execute conn query args+ `catch` ( \e -> do+ putStrLn $+ unlines+ [ unwords+ ["Query failed: " ++ show query],+ displayException (e :: SomeException)+ ]+ throwIO e+ )
sydtest-persistent-postgresql.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: sydtest-persistent-postgresql-version: 0.2.0.3+version: 0.3.0.0 synopsis: An persistent-postgresql companion library for sydtest category: Testing homepage: https://github.com/NorfairKing/sydtest#readme@@ -42,8 +42,12 @@ , monad-logger , mtl , persistent-postgresql+ , postgres-options+ , postgresql-simple+ , random , sydtest , sydtest-persistent+ , text , tmp-postgres default-language: Haskell2010
test/Test/Syd/Persistent/PostgresqlSpec.hs view
@@ -7,10 +7,9 @@ import Test.Syd.Persistent.Postgresql spec :: Spec-spec =- describe "persistPostgresqlSpec" $ do- postgresqlMigrationSucceedsSpec "test_resources/migration.sql" migrateExample-+spec = do+ postgresqlMigrationSucceedsSpec "test_resources/migration.sql" migrateExample+ describe "persistPostgresqlSpec" $ persistPostgresqlSpec migrateExample $ do it "can write and read this example person" $ \pool -> runPostgresqlTest pool $ do
test_resources/migration.sql view
@@ -3,7 +3,7 @@ -- ATTENTION CODE REVIEWER -- If this file has been updated, please make sure to check -- whether this test failed before that happened:--- "Test.Syd.Persistent.PostgresqlSpec.persistPostgresqlSpec.Can automatically migrate from the previous database schema"+-- "Test.Syd.Persistent.PostgresqlSpec.Can automatically migrate from the previous database schema" -- 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.