diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,5 @@ +# Sydtest License + +Copyright (c) 2021 Tom Sydney Kerckhove + +See the Sydtest License at https://github.com/NorfairKing/sydtest/blob/master/sydtest/LICENSE.md for the full license text. diff --git a/src/Test/Syd/Persistent/Postgresql.hs b/src/Test/Syd/Persistent/Postgresql.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Persistent/Postgresql.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Testing with a temporary postgresql database using persistent-postgresql +module Test.Syd.Persistent.Postgresql + ( persistPostgresqlSpec, + withConnectionPool, + connectionPoolSetupFunc, + runSqlPool, + runPostgresqlTest, + ) +where + +import Control.Monad.Logger +import Control.Monad.Reader +import Database.Persist.Postgresql +import Database.Postgres.Temp as Temp +import Test.Syd + +-- | Declare a test suite that uses a database connection. +-- +-- Example usage +-- +-- > -- Database definition +-- > share +-- > [mkPersist sqlSettings, mkMigrate "migrateExample"] +-- > [persistLowerCase| +-- > Person +-- > name String +-- > age Int Maybe +-- > deriving Show Eq +-- > |] +-- > +-- > -- Tests +-- > spec :: Spec +-- > spec = +-- > persistPostgresqlSpec migrateExample $ do +-- > it "can write and read this example person" $ \pool -> +-- > runPostgresqlTest pool $ do +-- > let p = Person {personName = "John Doe", personAge = Just 21} +-- > i <- insert p +-- > mp <- get i +-- > 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 + +-- | Set up a postgresql connection and migrate it to run the given function. +withConnectionPool :: Migration -> (ConnectionPool -> IO r) -> IO r +withConnectionPool = unSetupFunc . connectionPoolSetupFunc + +-- | 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 + +#if MIN_VERSION_persistent(2,10,2) +migrationRunner :: MonadIO m => Migration -> ReaderT SqlBackend m () +migrationRunner = void . runMigrationQuiet +#else +migrationRunner :: MonadIO m => Migration -> ReaderT SqlBackend m () +migrationRunner = runMigration +#endif + +-- | A flipped version of 'runSqlPool' to run your tests +runPostgresqlTest :: ConnectionPool -> SqlPersistT IO a -> IO a +runPostgresqlTest = flip runSqlPool diff --git a/sydtest-persistent-postgresql.cabal b/sydtest-persistent-postgresql.cabal new file mode 100644 --- /dev/null +++ b/sydtest-persistent-postgresql.cabal @@ -0,0 +1,69 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: sydtest-persistent-postgresql +version: 0.1.0.0 +synopsis: An persistent-postgresql 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 +license: OtherLicense +license-file: LICENSE.md +build-type: Simple + +source-repository head + type: git + location: https://github.com/NorfairKing/sydtest + +flag sydtest_integration_tests + description: Whether to allow building integration tests + manual: False + default: True + +library + exposed-modules: + Test.Syd.Persistent.Postgresql + other-modules: + Paths_sydtest_persistent_postgresql + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , monad-logger + , mtl + , persistent + , persistent-postgresql + , sydtest + , tmp-postgres + default-language: Haskell2010 + +test-suite sydtest-persistent-postgresql-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Syd.Persistent.Example + Test.Syd.Persistent.PostgresqlSpec + Paths_sydtest_persistent_postgresql + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-tool-depends: + sydtest-discover:sydtest-discover + build-depends: + base >=4.7 && <5 + , persistent + , persistent-postgresql + , persistent-template + , sydtest + , sydtest-persistent-postgresql + if flag(sydtest_integration_tests) + buildable: True + else + buildable: False + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/Test/Syd/Persistent/Example.hs b/test/Test/Syd/Persistent/Example.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Persistent/Example.hs @@ -0,0 +1,28 @@ +{-# 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/Persistent/PostgresqlSpec.hs b/test/Test/Syd/Persistent/PostgresqlSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Persistent/PostgresqlSpec.hs @@ -0,0 +1,27 @@ +module Test.Syd.Persistent.PostgresqlSpec (spec) where + +import Database.Persist +import Database.Persist.Sql +import Test.Syd +import Test.Syd.Persistent.Example +import Test.Syd.Persistent.Postgresql + +spec :: Spec +spec = + describe "persistPostgresqlSpec" $ do + persistPostgresqlSpec migrateExample $ do + it "can write and read this example person" $ \pool -> + runPostgresqlTest 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 -> + runPostgresqlTest pool $ do + let p = Person {personName = "John Doe", personAge = Just 21} + insert_ p + it "cannot read anything that has not been written yet" $ \pool -> + runPostgresqlTest pool $ do + mp <- get (toSqlKey 0) + liftIO $ mp `shouldBe` (Nothing :: Maybe Person)