pg-transact 0.1.2.0 → 0.2.0.0

raw patch · 3 files changed

+83/−41 lines, 3 filesdep +hspec-expectations-liftedPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec-expectations-lifted

API changes (from Hackage documentation)

Files

• pg-transact.cabal +2/−1
• src/Database/PostgreSQL/Transact.hs +45/−24
• test/Database/PostgreSQL/TransactSpec.hs +36/−16

@@ -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 

@@ -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

@@ -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"]