pg-transact (empty) → 0.1.0.0
raw patch · 7 files changed
+296/−0 lines, 7 filesdep +basedep +bytestringdep +exceptionssetup-changed
Dependencies added: base, bytestring, exceptions, hspec, hspec-discover, monad-control, pg-transact, postgresql-simple, tmp-postgres, transformers
Files
- LICENSE +28/−0
- README.md +1/−0
- Setup.hs +2/−0
- pg-transact.cabal +46/−0
- src/Database/PostgreSQL/Transact.hs +79/−0
- test/Database/PostgreSQL/TransactSpec.hs +139/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright 2016 - Helium Systems, Inc.+Copyright 2017 - Jonathan Fischoff++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++ * Neither the name of the copyright holder nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# pg-transact
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pg-transact.cabal view
@@ -0,0 +1,46 @@+name: pg-transact+version: 0.1.0.0+synopsis: Another postgresql-simple transaction monad+description: Another postgresql-simple transaction monad+homepage: https://github.com/jfischoff/pg-transact#readme+license: BSD3+license-file: LICENSE+author: Jonathan Fischoff+maintainer: jonathangfischoff@gmail.com+copyright: 2017 Jonathan Fischoff+category: Web+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Database.PostgreSQL.Transact+ build-depends: base >= 4.7 && < 5+ , postgresql-simple+ , transformers+ , monad-control+ , exceptions+ , bytestring+ ghc-options: -Wall+ default-language: Haskell2010++test-suite pg-transact-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Database.PostgreSQL.TransactSpec+ build-depends: base+ , bytestring+ , exceptions+ , hspec+ , hspec-discover+ , postgresql-simple+ , pg-transact+ , tmp-postgres+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/jfischoff/pg-transact
+ src/Database/PostgreSQL/Transact.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, RecordWildCards, OverloadedStrings #-}+module Database.PostgreSQL.Transact where+import Control.Monad.Trans.Reader+import Database.PostgreSQL.Simple as Simple+import Database.PostgreSQL.Simple.Transaction+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Control+import Control.Monad.Catch+import Data.Int+import Control.Monad+import qualified Data.ByteString as BS++newtype DBT m a = DBT { unDBT :: ReaderT Connection m a }+ deriving (MonadTrans, MonadThrow)++type DB = DBT IO++instance Functor m => Functor (DBT m) where+ fmap f = DBT . fmap f . unDBT++instance Applicative m => Applicative (DBT m) where+ pure = DBT . pure+ f <*> v = DBT $ unDBT f <*> unDBT v++instance MonadIO m => MonadIO (DBT m) where+ liftIO = lift . liftIO++instance Monad m => Monad (DBT m) where+ return = lift . return+ DBT m >>= k = DBT $ m >>= unDBT . k++isClass25 :: SqlError -> Bool+isClass25 SqlError{..} = BS.take 2 sqlState == "25"++instance (MonadIO m, MonadMask m) => MonadCatch (DBT m) where+ catch (DBT act) handler = DBT $ mask $ \restore -> do+ conn <- ask+ sp <- liftIO $ newSavepoint conn+ let setup = catch (restore act) $ \e -> do+ liftIO $ rollbackToSavepoint conn sp+ unDBT $ handler e++ setup `finally` liftIO (tryJust (guard . isClass25) (releaseSavepoint conn sp))++getConnection :: Monad m => DBT m Connection+getConnection = DBT ask++runDBT :: MonadBaseControl IO m => DBT m a -> IsolationLevel -> Connection -> m a+runDBT action level conn+ = control+ $ \run -> 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+ $ runReaderT (unDBT action) conn++query :: (ToRow a, FromRow b, MonadIO m) => Query -> a -> DBT m [b]+query q x = getConnection >>= \conn -> liftIO $ Simple.query conn q x++query_ :: (FromRow b, MonadIO m) => Query -> DBT m [b]+query_ q = getConnection >>= \conn -> liftIO $ Simple.query_ conn q++execute :: (ToRow q, MonadIO m) => Query -> q -> DBT m Int64+execute q x = getConnection >>= \conn -> liftIO $ Simple.execute conn q x++execute_ :: MonadIO m => Query -> DBT m Int64+execute_ q = getConnection >>= \conn -> liftIO $ Simple.execute_ conn q++executeMany :: (ToRow q, MonadIO m) => Query -> [q] -> DBT m Int64+executeMany q xs = getConnection >>= \conn -> liftIO $ Simple.executeMany conn q xs++returning :: (ToRow q, FromRow r, MonadIO m) => Query -> [q] -> DBT m [r]+returning q xs = getConnection >>= \conn -> liftIO $ Simple.returning conn q xs
+ test/Database/PostgreSQL/TransactSpec.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Database.PostgreSQL.TransactSpec where++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+ , Only (..)+ , SqlError (..)+ )+import Database.PostgreSQL.Simple.SqlQQ+import Database.PostgreSQL.Transact+import qualified Database.Postgres.Temp as Temp+import Test.Hspec++------------------------- 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)++shutdown :: (Connection, Temp.DB) -> IO ()+shutdown (conn, db) = do+ PS.close conn+ void $ Temp.stop db++------------------------- Test Utilities -------------------------+insertFruit :: String -> DB ()+insertFruit fruit+ = void $ execute [sql| INSERT INTO fruit (name) VALUES (?) |] (Only fruit)++fruits :: Connection -> IO [String]+fruits conn+ = fmap (map fromOnly)+ $ PS.query_ conn [sql|SELECT name FROM fruit ORDER BY name|]++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)++instance Exception Forbidden++------------------------- 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 `shouldBeM` ["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"++ fruits conn `shouldBeM` ["apple"]++ before createDB $ do+ it "multiple execute_'s succeed" $ \(conn, _) -> do+ runDB conn $ do+ insertFruit "grapes"+ insertFruit "orange"++ fruits conn `shouldBeM` ["grapes", "orange"]++ it "throwM causes a rollback" $ \(conn, _) -> do+ flip shouldThrow (\Forbidden -> True) $+ runDB conn $ do+ insertFruit "salak"+ () <- throwM Forbidden+ insertFruit "banana"++ fruits conn `shouldBeM` []++ 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 `shouldBeM` ["banana", "tomato"]++ 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 `shouldBeM` ["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 `shouldBeM` ["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"++ fruits conn `shouldBeM` []
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}