diff --git a/pg-transact.cabal b/pg-transact.cabal --- a/pg-transact.cabal +++ b/pg-transact.cabal @@ -1,5 +1,5 @@ name: pg-transact -version: 0.1.2.0 +version: 0.2.0.0 synopsis: Another postgresql-simple transaction monad description: Another postgresql-simple transaction monad homepage: https://github.com/jfischoff/pg-transact#readme @@ -38,6 +38,7 @@ , postgresql-simple , pg-transact , tmp-postgres + , hspec-expectations-lifted ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Database/PostgreSQL/Transact.hs b/src/Database/PostgreSQL/Transact.hs --- a/src/Database/PostgreSQL/Transact.hs +++ b/src/Database/PostgreSQL/Transact.hs @@ -1,9 +1,10 @@ {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, RecordWildCards, OverloadedStrings #-} module Database.PostgreSQL.Transact where import Control.Monad.Trans.Reader -import Database.PostgreSQL.Simple as Simple +import qualified Database.PostgreSQL.Simple as Simple +import Database.PostgreSQL.Simple (ToRow, FromRow, Connection, SqlError (..)) import Database.PostgreSQL.Simple.Types as Simple -import Database.PostgreSQL.Simple.Transaction +import qualified Database.PostgreSQL.Simple.Transaction as Simple import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Control @@ -11,7 +12,6 @@ import Data.Int import Control.Monad import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC import qualified Control.Monad.Fail as Fail newtype DBT m a = DBT { unDBT :: ReaderT Connection m a } @@ -42,27 +42,43 @@ instance (MonadIO m, MonadMask m) => MonadCatch (DBT m) where catch (DBT act) handler = DBT $ mask $ \restore -> do conn <- ask - sp <- liftIO $ newSavepoint conn + sp <- liftIO $ Simple.newSavepoint conn let setup = catch (restore act) $ \e -> do - liftIO $ rollbackToSavepoint conn sp + liftIO $ Simple.rollbackToSavepoint conn sp unDBT $ handler e - setup `finally` liftIO (tryJust (guard . isClass25) (releaseSavepoint conn sp)) + setup `finally` liftIO (tryJust (guard . isClass25) (Simple.releaseSavepoint conn sp)) +instance (MonadIO m, MonadMask m) => MonadMask (DBT m) where + mask a = DBT $ mask $ \u -> unDBT (a $ q u) + where q :: (ReaderT Connection m a -> ReaderT Connection m a) -> DBT m a -> DBT m a + q u (DBT b) = DBT $ u b + + uninterruptibleMask a = + DBT $ uninterruptibleMask $ \u -> unDBT (a $ q u) + where q :: (ReaderT Connection m a -> ReaderT Connection m a) -> DBT m a -> DBT m a + q u (DBT b) = DBT $ u b + + generalBracket acquire release use = DBT $ + generalBracket + (unDBT acquire) + (\resource exitCase -> unDBT (release resource exitCase)) + (\resource -> unDBT (use resource)) + getConnection :: Monad m => DBT m Connection getConnection = DBT ask -runDBT :: MonadBaseControl IO m => DBT m a -> IsolationLevel -> Connection -> m a +runDBT :: MonadBaseControl IO m => DBT m a -> Simple.IsolationLevel -> Connection -> m a runDBT action level conn = control - $ \run -> withTransactionLevel level conn + $ \run -> Simple.withTransactionLevel level conn $ run $ runReaderT (unDBT action) conn runDBTSerializable :: MonadBaseControl IO m => DBT m a -> Connection -> m a runDBTSerializable action conn = control - $ \run -> withTransactionSerializable conn + $ \run -> Simple.withTransactionSerializable conn $ run $ runReaderT (unDBT action) conn @@ -167,27 +183,32 @@ formatQuery :: (ToRow q, MonadIO m) => Query -> q -> DBT m BS.ByteString formatQuery q xs = getConnection >>= \conn -> liftIO $ Simple.formatQuery conn q xs -newtype TooManyRows = TooManyRows String - deriving(Show, Eq) - -instance Exception TooManyRows - -queryOne :: (ToRow a, FromRow b) => Query -> a -> DB (Maybe b) +queryOne :: (MonadIO m, MonadThrow m, ToRow a, FromRow b) => Query -> a -> DBT m (Maybe b) queryOne q x = do - rows <- Database.PostgreSQL.Transact.query q x + rows <- query q x case rows of [] -> return Nothing [a] -> return $ Just a - _ -> do - let Simple.Query str = q - throwM $ TooManyRows $ BSC.unpack str + _ -> return Nothing -queryOne_ :: FromRow b => Query -> DB (Maybe b) +queryOne_ :: (MonadIO m, MonadThrow m, FromRow b) => Query -> DBT m (Maybe b) queryOne_ q = do - rows <- Database.PostgreSQL.Transact.query_ q + rows <- query_ q case rows of [] -> return Nothing [x] -> return $ Just x - _ -> do - let Simple.Query str = q - throwM $ TooManyRows $ BSC.unpack str + _ -> return Nothing + +-- | Create a 'Savepoint'. +savepoint :: DB Savepoint +savepoint = getConnection >>= liftIO . Simple.newSavepoint + +-- | Release the 'Savepoint' and discard the effects. +rollbackToAndReleaseSavepoint :: Savepoint -> DB () +rollbackToAndReleaseSavepoint sp = getConnection >>= liftIO . flip Simple.rollbackToAndReleaseSavepoint sp + +-- | Run an action and discard the effects. +rollback :: DB () -> DB () +rollback actionToRollback = mask $ \restore -> do + sp <- savepoint + restore actionToRollback `finally` rollbackToAndReleaseSavepoint sp diff --git a/test/Database/PostgreSQL/TransactSpec.hs b/test/Database/PostgreSQL/TransactSpec.hs --- a/test/Database/PostgreSQL/TransactSpec.hs +++ b/test/Database/PostgreSQL/TransactSpec.hs @@ -6,7 +6,6 @@ import Control.Monad (void) import Control.Monad.Catch import qualified Data.ByteString.Char8 as BSC -import Data.String import Data.Typeable import qualified Database.PostgreSQL.Simple as PS import Database.PostgreSQL.Simple ( Connection @@ -16,7 +15,8 @@ import Database.PostgreSQL.Simple.SqlQQ import Database.PostgreSQL.Transact import qualified Database.Postgres.Temp as Temp -import Test.Hspec +import Test.Hspec (Spec, describe, beforeAll, before, after, afterAll, it, shouldThrow) +import Test.Hspec.Expectations.Lifted (shouldReturn) ------------------------- Test DB Creation ------------------------- createDB :: IO (Connection, Temp.DB) @@ -33,11 +33,19 @@ PS.close conn void $ Temp.stop db +withDb :: DB a -> (Connection, b) -> IO a +withDb action (conn, _) = runDB conn action + ------------------------- Test Utilities ------------------------- insertFruit :: String -> DB () insertFruit fruit = void $ execute [sql| INSERT INTO fruit (name) VALUES (?) |] (Only fruit) +getFruits :: DB [String] +getFruits + = fmap (map fromOnly) + $ query_ [sql|SELECT name FROM fruit ORDER BY name|] + fruits :: Connection -> IO [String] fruits conn = fmap (map fromOnly) @@ -46,11 +54,6 @@ runDB :: Connection -> DB a -> IO a runDB = flip runDBTSerializable -shouldBeM :: (Eq a, Show a) => IO a -> a -> IO () -shouldBeM action expected = do - actual <- action - actual `shouldBe` expected - -- Simple exception type for testing data Forbidden = Forbidden deriving (Show, Eq, Typeable) @@ -66,7 +69,7 @@ let apple = "apple" runDB conn $ insertFruit apple - fruits conn `shouldBeM` ["apple"] + fruits conn `shouldReturn` ["apple"] it "execute_ rollbacks on exception" $ \(conn, _) -> do flip shouldThrow (\(SqlError {}) -> True) $ @@ -76,15 +79,15 @@ -- constraint on 'name' insertFruit "apple" - fruits conn `shouldBeM` ["apple"] + fruits conn `shouldReturn` ["apple"] - before createDB $ do + before createDB $ after shutdown $ do it "multiple execute_'s succeed" $ \(conn, _) -> do runDB conn $ do insertFruit "grapes" insertFruit "orange" - fruits conn `shouldBeM` ["grapes", "orange"] + fruits conn `shouldReturn` ["grapes", "orange"] it "throwM causes a rollback" $ \(conn, _) -> do flip shouldThrow (\Forbidden -> True) $ @@ -93,7 +96,7 @@ () <- throwM Forbidden insertFruit "banana" - fruits conn `shouldBeM` [] + fruits conn `shouldReturn` [] it "query recovers when exception is caught" $ \(conn, _) -> do runDB conn $ do @@ -103,7 +106,7 @@ insertFruit "salak" throwM Forbidden - fruits conn `shouldBeM` ["banana", "tomato"] + fruits conn `shouldReturn` ["banana", "tomato"] it "multiple catch statements work correctly" $ \(conn, _) -> do runDB conn $ do @@ -116,7 +119,7 @@ insertFruit "salak" throwM Forbidden - fruits conn `shouldBeM` ["banana", "blueberry", "frankenberry"] + fruits conn `shouldReturn` ["banana", "blueberry", "frankenberry"] it "alternate branches can also have savepoints" $ \(conn, _) -> do runDB conn $ do @@ -128,7 +131,7 @@ insertFruit "salak" throwM Forbidden - fruits conn `shouldBeM` ["banana", "blueberry", "frankenberry"] + fruits conn `shouldReturn` ["banana", "blueberry", "frankenberry"] it "releasing silently fails if the transaction errors" $ \(conn, _) -> do runDB conn $ do @@ -136,4 +139,21 @@ catchAll (void $ execute_ [sql| ABORT |]) $ \_ -> insertFruit "tomato" - fruits conn `shouldBeM` [] + fruits conn `shouldReturn` [] + + it "rollback ... rollbacks effects on expected finish" $ withDb $ do + insertFruit "grapes" + rollback $ do + insertFruit "oranges" + getFruits `shouldReturn` ["grapes", "oranges"] + + getFruits `shouldReturn` ["grapes"] + + it "rollback ... rollbacks effects on exception" $ withDb $ do + insertFruit "grapes" + _ :: Either Forbidden () <- try $ rollback $ do + insertFruit "oranges" + getFruits `shouldReturn` ["grapes", "oranges"] + throwM Forbidden + + getFruits `shouldReturn` ["grapes"]