pg-transact 0.2.1.0 → 0.3.0.0

raw patch · 6 files changed

+141/−99 lines, 6 filesdep +asyncdep −hspec-discoverdep ~tmp-postgresPVP ok

version bump matches the API change (PVP)

Dependencies added: async

Dependencies removed: hspec-discover

Dependency ranges changed: tmp-postgres

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• README.md +1/−0
• pg-transact.cabal +6/−5
• src/Database/PostgreSQL/Transact.hs +5/−5
• test/Database/PostgreSQL/TransactSpec.hs +121/−88
• test/Spec.hs +5/−1

@@ -0,0 +1,3 @@+- 0.3.0.0+  - #4 Generalize `rollback` and related queries to use DBT+  - #3 Remove MonadThrow constraint from queryOne

@@ -1,1 +1,2 @@ # pg-transact+[![Travis CI Status](https://travis-ci.org/jfischoff/pg-transact.svg?branch=master)](http://travis-ci.org/jfischoff/pg-transact)

@@ -1,6 +1,6 @@ name:                pg-transact-version:             0.2.1.0-synopsis: Another postgresql-simple transaction monad+version:             0.3.0.0+synopsis: A postgresql-simple transaction monad description: Another postgresql-simple transaction monad homepage:            https://github.com/jfischoff/pg-transact#readme license:             BSD3@@ -10,7 +10,8 @@ copyright:           2017 Jonathan Fischoff category:            Web build-type:          Simple-extra-source-files:  README.md+extra-source-files: README.md+                  , CHANGELOG.md cabal-version:       >=1.10  library@@ -31,13 +32,13 @@   main-is:             Spec.hs   other-modules: Database.PostgreSQL.TransactSpec   build-depends: base+               , async                , bytestring                , exceptions                , hspec-               , hspec-discover                , postgresql-simple                , pg-transact-               , tmp-postgres+               , tmp-postgres >= 1.34.0.0                , hspec-expectations-lifted   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010

@@ -194,7 +194,7 @@ formatQuery :: (ToRow q, MonadIO m) => Query -> q -> DBT m BS.ByteString formatQuery q xs = getConnection >>= \conn -> liftIO $ Simple.formatQuery conn q xs -queryOne :: (MonadIO m, MonadThrow m, ToRow a, FromRow b) => Query -> a -> DBT m (Maybe b)+queryOne :: (MonadIO m, ToRow a, FromRow b) => Query -> a -> DBT m (Maybe b) queryOne q x = do   rows <- query q x   case rows of@@ -202,7 +202,7 @@     [a] -> return $ Just a     _   -> return Nothing -queryOne_ :: (MonadIO m, MonadThrow m, FromRow b) => Query -> DBT m (Maybe b)+queryOne_ :: (MonadIO m, FromRow b) => Query -> DBT m (Maybe b) queryOne_ q = do   rows <- query_ q   case rows of@@ -211,15 +211,15 @@     _   -> return Nothing  -- | Create a 'Savepoint'.-savepoint :: DB Savepoint+savepoint :: MonadIO m => DBT m Savepoint savepoint = getConnection >>= liftIO . Simple.newSavepoint  -- | Release the 'Savepoint' and discard the effects.-rollbackToAndReleaseSavepoint :: Savepoint -> DB ()+rollbackToAndReleaseSavepoint :: MonadIO m => Savepoint -> DBT m () rollbackToAndReleaseSavepoint sp = getConnection >>= liftIO . flip Simple.rollbackToAndReleaseSavepoint sp  -- | Run an action and discard the effects but return the result-rollback :: DB a -> DB a+rollback :: (MonadMask m, MonadIO m) => DBT m a -> DBT m a rollback actionToRollback = mask $ \restore -> do   sp <- savepoint   restore actionToRollback `finally` rollbackToAndReleaseSavepoint sp

@@ -5,7 +5,6 @@  import           Control.Monad              (void) import           Control.Monad.Catch-import qualified Data.ByteString.Char8      as BSC import           Data.Typeable import qualified Database.PostgreSQL.Simple as PS import           Database.PostgreSQL.Simple ( Connection@@ -15,27 +14,60 @@ import           Database.PostgreSQL.Simple.SqlQQ import           Database.PostgreSQL.Transact import qualified Database.Postgres.Temp as Temp-import           Test.Hspec (Spec, describe, beforeAll, before, after, afterAll, it, shouldThrow)+import           Test.Hspec (Spec, SpecWith, describe, beforeAll, afterAll, it, shouldThrow, runIO) import           Test.Hspec.Expectations.Lifted (shouldReturn)+import           Data.IORef+import           Control.Concurrent+import           Control.Concurrent.Async+import           Data.Foldable+import qualified Control.Exception as E+import           Control.Monad ((<=<)) +aroundAll :: forall a. ((a -> IO ()) -> IO ()) -> SpecWith a -> Spec+aroundAll withFunc specWith = do+  (var, stopper, asyncer) <- runIO $+    (,,) <$> newEmptyMVar <*> newEmptyMVar <*> newIORef Nothing+  let theStart :: IO a+      theStart = do++        thread <- async $ do+          withFunc $ \x -> do+            putMVar var x+            takeMVar stopper+          pure $ error "Don't evaluate this"++        writeIORef asyncer $ Just thread++        either pure pure =<< (wait thread `race` takeMVar var)++      theStop :: a -> IO ()+      theStop _ = do+        putMVar stopper ()+        traverse_ cancel =<< readIORef asyncer++  beforeAll theStart $ afterAll theStop $ specWith+ -------------------------       Test DB Creation       --------------------------createDB :: IO (Connection, Temp.DB)-createDB = do-    Right tempDB <- Temp.startAndLogToTmp []-    let connectionString = Temp.connectionString tempDB-    connection <- PS.connectPostgreSQL $ BSC.pack connectionString-    void $ PS.execute_ connection $-        [sql| CREATE TABLE fruit (name VARCHAR(100) PRIMARY KEY ) |]-    return (connection, tempDB)+withConn :: Temp.DB -> (Connection -> IO a) -> IO a+withConn db f = do+  let connStr = Temp.toConnectionString db+  bracket (PS.connectPostgreSQL connStr) PS.close f -shutdown :: (Connection, Temp.DB) -> IO ()-shutdown (conn, db) = do-  PS.close conn-  void $ Temp.stop db+withSetup :: (Connection -> IO ()) -> IO ()+withSetup f = either E.throwIO pure <=< Temp.withDbCache $ \dbCache ->+  Temp.withConfig (Temp.defaultConfig <> Temp.cacheConfig dbCache) $ \db ->+    withConn db $ \conn -> do+      void $ PS.execute_ conn $+          [sql| CREATE TABLE fruit (name VARCHAR(100) PRIMARY KEY ) |]+      f conn -withDb :: DB a -> (Connection, b) -> IO a-withDb action (conn, _) = runDB conn action +withDb :: DB a -> Connection -> IO a+withDb action conn = runDB conn action++runDB :: Connection -> DB a -> IO a+runDB = flip runDBTSerializable+ -------------------------        Test Utilities        ------------------------- insertFruit :: String -> DB () insertFruit fruit@@ -51,9 +83,6 @@   = fmap (map fromOnly)   $ PS.query_ conn [sql|SELECT name FROM fruit ORDER BY name|] -runDB :: Connection -> DB a -> IO a-runDB = flip runDBTSerializable- -- Simple exception type for testing data Forbidden = Forbidden     deriving (Show, Eq, Typeable)@@ -63,97 +92,101 @@ -------------------------         Tests Start          ------------------------- spec :: Spec spec = describe "TransactionSpec" $ do-    -- Notice the 'beforeAll'. The second test uses the same db as the first-    beforeAll createDB $ afterAll shutdown $ do-        it "execute_ happen path succeeds" $ \(conn, _) -> do-            let apple = "apple"-            runDB conn $ insertFruit apple--            fruits conn `shouldReturn` ["apple"]--        it "execute_ rollbacks on exception" $ \(conn, _) -> do-            flip shouldThrow (\(SqlError {}) -> True) $-                runDB conn $ do-                    insertFruit "orange"-                    -- This should cause an exception because of the UNIQUE-                    -- constraint on 'name'-                    insertFruit "apple"+  aroundAll withSetup $ do+    it "execute_ happen path succeeds" $ \conn -> do+        let apple = "apple"+        runDB conn $ insertFruit apple -            fruits conn `shouldReturn` ["apple"]+        fruits conn `shouldReturn` [apple] -    before createDB $ after shutdown $ do-        it "multiple execute_'s succeed" $ \(conn, _) -> do+    it "execute_ rollbacks on exception" $ \conn -> do+        flip shouldThrow (\(SqlError {}) -> True) $             runDB conn $ do-                insertFruit "grapes"                 insertFruit "orange"+                -- This should cause an exception because of the UNIQUE+                -- constraint on 'name'+                insertFruit "apple" -            fruits conn `shouldReturn` ["grapes", "orange"]+        fruits conn `shouldReturn` ["apple"] -        it "throwM causes a rollback" $ \(conn, _) -> do-            flip shouldThrow (\Forbidden -> True) $-                runDB conn $ do-                    insertFruit "salak"-                    () <- throwM Forbidden-                    insertFruit "banana"+  aroundAll withSetup $ do+    it "multiple execute_'s succeed" $ \conn -> do+        runDB conn $ do+            insertFruit "grapes"+            insertFruit "orange" -            fruits conn `shouldReturn` []+        fruits conn `shouldReturn` ["grapes", "orange"] -        it "query recovers when exception is caught" $ \(conn, _) -> do+  aroundAll withSetup $ do+    it "throwM causes a rollback" $ \conn -> do+        flip shouldThrow (\Forbidden -> True) $             runDB conn $ do-                -- This should always happen because of the handle below+                insertFruit "salak"+                () <- throwM Forbidden                 insertFruit "banana"-                handle (\Forbidden -> insertFruit "tomato") $ do++        fruits conn `shouldReturn` []++    it "query recovers when exception is caught" $ \conn -> do+        runDB conn $ do+            -- This should always happen because of the handle below+            insertFruit "banana"+            handle (\Forbidden -> insertFruit "tomato") $ do+                insertFruit "salak"+                throwM Forbidden++        fruits conn `shouldReturn` ["banana", "tomato"]++  aroundAll withSetup $ do+    it "multiple catch statements work correctly" $ \conn -> do+        runDB conn $ do+            insertFruit "banana"+            handle (\Forbidden -> insertFruit "tomato") $ do+                -- This will happen ... even if there is an exception below+                -- if we catch it+                insertFruit "blueberry"+                handle (\Forbidden -> insertFruit "frankenberry") $ do                     insertFruit "salak"                     throwM Forbidden -            fruits conn `shouldReturn` ["banana", "tomato"]+        fruits conn `shouldReturn` ["banana", "blueberry", "frankenberry"] -        it "multiple catch statements work correctly" $ \(conn, _) -> do-            runDB conn $ do-                insertFruit "banana"-                handle (\Forbidden -> insertFruit "tomato") $ do-                    -- This will happen ... even if there is an exception below-                    -- if we catch it+  aroundAll withSetup $ do+    it "alternate branches can also have savepoints" $ \conn -> do+        runDB conn $ do+            insertFruit "banana"+            catch (insertFruit "tomato" >> throwM Forbidden) $+                \Forbidden -> do                     insertFruit "blueberry"                     handle (\Forbidden -> insertFruit "frankenberry") $ do                         insertFruit "salak"                         throwM Forbidden -            fruits conn `shouldReturn` ["banana", "blueberry", "frankenberry"]--        it "alternate branches can also have savepoints" $ \(conn, _) -> do-            runDB conn $ do-                insertFruit "banana"-                catch (insertFruit "tomato" >> throwM Forbidden) $-                    \Forbidden -> do-                        insertFruit "blueberry"-                        handle (\Forbidden -> insertFruit "frankenberry") $ do-                            insertFruit "salak"-                            throwM Forbidden--            fruits conn `shouldReturn` ["banana", "blueberry", "frankenberry"]+        fruits conn `shouldReturn` ["banana", "blueberry", "frankenberry"] -        it "releasing silently fails if the transaction errors" $ \(conn, _) -> do-            runDB conn $ do-                insertFruit "banana"-                catchAll (void $ execute_ [sql| ABORT |]) $-                    \_ -> insertFruit "tomato"+  aroundAll withSetup $ do+    it "releasing silently fails if the transaction errors" $ \conn -> do+        runDB conn $ do+            insertFruit "banana"+            catchAll (void $ execute_ [sql| ABORT |]) $+                \_ -> insertFruit "tomato" -            fruits conn `shouldReturn` []+        fruits conn `shouldReturn` [] -        it "rollback ... rollbacks effects on expected finish" $ withDb $ do-          insertFruit "grapes"-          rollback $ do-            insertFruit "oranges"-            getFruits `shouldReturn` ["grapes", "oranges"]+    it "rollback ... rollbacks effects on expected finish" $ withDb $ do+      insertFruit "grapes"+      rollback $ do+        insertFruit "oranges"+        getFruits `shouldReturn` ["grapes", "oranges"] -          getFruits `shouldReturn` ["grapes"]+      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+  aroundAll withSetup $ do+    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"]+      getFruits `shouldReturn` ["grapes"]

@@ -1,1 +1,5 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+import Database.PostgreSQL.TransactSpec+import Test.Hspec++main :: IO ()+main = hspec spec