diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 0.1.0.0 (November 21st, 2017) + +- Changed `runDB` and `runDBCommit` to properly roll back a transaction if an exception is raised. + ## 0.0.1.0 (April 24th, 2017) - Initial release diff --git a/genesis-test.cabal b/genesis-test.cabal --- a/genesis-test.cabal +++ b/genesis-test.cabal @@ -1,9 +1,9 @@ --- This file has been generated from package.yaml by hpack version 0.15.0. +-- This file has been generated from package.yaml by hpack version 0.18.1. -- -- see: https://github.com/sol/hpack name: genesis-test -version: 0.0.1.0 +version: 0.1.0.0 synopsis: Opinionated bootstrapping for Haskell web services. description: Opinionated bootstrapping for Haskell web services. category: Other @@ -30,20 +30,23 @@ default-extensions: ConstraintKinds DeriveGeneric DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeOperators ghc-options: -Wall build-depends: - base >= 4.9.0.0 && < 5 - , genesis == 0.0.1.0 + base >= 4.9 && < 5 + , genesis == 0.1.0.0 , hspec - , hspec-expectations >= 0.7.0 + , hspec-expectations >= 0.7 , lifted-base - , monad-control >= 1.0.0.0 && < 2 + , monad-control >= 1 && < 2 , monad-logger >= 0.3.10 - , monad-persist >= 0.0.1.0 && < 1 + , monad-persist >= 0.0.1.2 && < 1 , persistent-postgresql >= 2.5 && < 3 + , transformers , transformers-base exposed-modules: Genesis.Test Genesis.Test.Hspec Genesis.Test.Persist + other-modules: + Paths_genesis_test default-language: Haskell2010 test-suite genesis-test-test-suite diff --git a/library/Genesis/Test/Persist.hs b/library/Genesis/Test/Persist.hs --- a/library/Genesis/Test/Persist.hs +++ b/library/Genesis/Test/Persist.hs @@ -43,12 +43,12 @@ import qualified Database.Persist.Postgresql as PG import qualified Genesis.Test.Hspec as Hspec -import Control.Exception (bracket_) +import Control.Exception.Lifted (bracket_, finally, onException) import Control.Monad.Base (liftBase) -import Control.Monad.IO.Class (MonadIO) import Control.Monad.Logger (runNoLoggingT) -import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.IORef.Lifted (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) import Genesis.Persist (PostgresOptions, withPostgresqlConn) import GHC.Stack (HasCallStack) @@ -63,7 +63,7 @@ does not exist (that is, you are not in the dynamic extent of a call to 'withGlobalPostgresqlConn'), this will raise an exception. -} -dbConn :: HasCallStack => MonadBaseControl IO m => m Persist.SqlBackend +dbConn :: (HasCallStack, MonadBaseControl IO m) => m Persist.SqlBackend dbConn = fromMaybe (error "dbConn: connection does not exist") <$> liftBase (readIORef dbConnRef) {-| @@ -76,17 +76,18 @@ concise, but this function is provided for uses that fall outside of simple @hspec@ examples. -} -runDB :: (MonadIO m, MonadBaseControl IO m) => Persist.SqlPersistT m a -> m a -runDB x = Persist.runPersistT (x <* Persist.transactionUndo) =<< dbConn +runDB :: MonadBaseControl IO m => Persist.SqlPersistT m a -> m a +runDB x = Persist.runPersistT (x `finally` Persist.transactionUndo) =<< dbConn {-| Like 'runDB', except that the transaction is commited after running instead of - rolled back. You should avoid this in test code to avoid creating tests that - dependent on the database state, but it can be useful to run migrations, for - example. + rolled back (unless an exception is raised, in which case the transaction is + rolled back, anyway). You should avoid this in test code to avoid creating + tests that dependent on the database state, but it can be useful to run + migrations, for example. -} -runDBCommit :: (MonadIO m, MonadBaseControl IO m) => Persist.SqlPersistT m a -> m a -runDBCommit x = Persist.runPersistT (x <* Persist.transactionSave) =<< dbConn +runDBCommit :: MonadBaseControl IO m => Persist.SqlPersistT m a -> m a +runDBCommit x = Persist.runPersistT ((x <* Persist.transactionSave) `onException` Persist.transactionUndo) =<< dbConn {-| A helper function that combines 'Hspec.example' with 'runDB'. This can be used @@ -110,9 +111,9 @@ extent of its execution. The connection is started within a transaction. -} withGlobalPostgresqlConn :: MonadBaseControl IO m => PostgresOptions -> m a -> m a -withGlobalPostgresqlConn opts = liftBaseOp_ $ \action -> +withGlobalPostgresqlConn opts action = runNoLoggingT $ withPostgresqlConn opts $ \conn -> do oldConn <- liftBase $ readIORef dbConnRef - liftBase $ bracket_ (writeIORef dbConnRef (Just conn)) (writeIORef dbConnRef oldConn) $ do - PG.connBegin conn (PG.getStmtConn conn) -- start a new transaction - action + bracket_ (writeIORef dbConnRef (Just conn)) (writeIORef dbConnRef oldConn) $ do + liftBase $ PG.connBegin conn (PG.getStmtConn conn) -- start a new transaction + lift action diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: genesis-test -version: 0.0.1.0 +version: 0.1.0.0 category: Other synopsis: Opinionated bootstrapping for Haskell web services. description: Opinionated bootstrapping for Haskell web services. @@ -34,15 +34,16 @@ library: dependencies: - - base >= 4.9.0.0 && < 5 - - genesis == 0.0.1.0 + - base >= 4.9 && < 5 + - genesis == 0.1.0.0 - hspec - - hspec-expectations >= 0.7.0 + - hspec-expectations >= 0.7 - lifted-base - - monad-control >= 1.0.0.0 && < 2 + - monad-control >= 1 && < 2 - monad-logger >= 0.3.10 - - monad-persist >= 0.0.1.0 && < 1 + - monad-persist >= 0.0.1.2 && < 1 - persistent-postgresql >= 2.5 && < 3 + - transformers - transformers-base source-dirs: library diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -5,7 +5,7 @@ - location: '../genesis' extra-dep: true -extra-deps: [monad-persist-0.0.1.0] +extra-deps: [monad-io-adapter-0.1.0.0, monad-persist-0.0.2.0] flags: {} diff --git a/test-suite/Genesis/Test/PersistSpec.hs b/test-suite/Genesis/Test/PersistSpec.hs --- a/test-suite/Genesis/Test/PersistSpec.hs +++ b/test-suite/Genesis/Test/PersistSpec.hs @@ -10,7 +10,7 @@ module Genesis.Test.PersistSpec (spec) where -import Control.Monad.Persist (Entity(..), insert, selectList) +import Control.Monad.Persist (Entity(..), insert, insert_, selectList) import Data.Text (Text) import Database.Persist.TH (mkPersist, persistLowerCase, sqlSettings) import Genesis.Test @@ -28,10 +28,24 @@ |] spec :: Spec -spec = describe "dbExample" $ - it "runs an Hspec example with access to the database" $ dbExample $ do - blogId <- insert $ Blog "Alyssa’s Blog" - let post = Post { postTitle = "First Post", postBody = "world changing post", postBlogId = blogId } - postId <- insert post - posts <- selectList [] [] - posts `shouldBe` [Entity postId post] +spec = do + describe "runDB" $ do + it "rolls back when the action completes succesfully" $ example $ do + runDB . insert_ $ Blog "Alyssa’s Blog" + runDB (selectList [] []) `shouldReturn` ([] :: [Entity Blog]) + + it "rolls back when the action fails with an exception" $ example $ do + shouldThrow + (runDB $ do + insert_ $ Blog "Alyssa’s Blog" + error "failure") + (errorCall "failure") + runDB (selectList [] []) `shouldReturn` ([] :: [Entity Blog]) + + describe "dbExample" $ + it "runs an Hspec example with access to the database" $ dbExample $ do + blogId <- insert $ Blog "Alyssa’s Blog" + let post = Post { postTitle = "First Post", postBody = "world changing post", postBlogId = blogId } + postId <- insert post + posts <- selectList [] [] + posts `shouldBe` [Entity postId post]