Add withTransaction

Author: anttih

MODULE.md

@@ -135,6 +135,25 @@ withClient :: forall eff a. ConnectionInfo -> (Client -> Aff (db :: DB | eff) a)
 Takes a Client from the connection pool, runs the given function with
 the client and returns the results.
 
+#### `withTransaction`
+
+``` purescript
+withTransaction :: forall eff a. (Client -> Aff (db :: DB | eff) a) -> Client -> Aff (db :: DB | eff) a
+```
+
+Runs an asynchronous action in a database transaction. The transaction
+will be rolled back if the computation fails and committed otherwise.
+
+Here the first insert will be rolled back:
+
+```purescript
+moneyTransfer :: forall e. (Client -> Aff e Unit) -> Client -> Aff e Unit
+moneyTransfer = withTransaction $ \c -> do
+  execute_ (Query "insert into accounts ...") c
+  throwError $ error "Something went wrong"
+  execute_ (Query "insert into accounts ...") c
+```
+
 #### `end`
 
 ``` purescript

src/Database/Postgres.purs

@@ -14,9 +14,11 @@ module Database.Postgres
   , queryOne, queryOne_
   , withConnection
   , withClient
+  , withTransaction
   ) where
 
 import Control.Alt
+import Control.Apply ((*>))
 import Control.Monad.Eff
 import Control.Monad.Trans
 import Data.Either
@@ -28,7 +30,7 @@ import Data.Maybe
 import Control.Monad.Aff
 import Control.Monad.Eff.Class
 import Control.Monad.Eff.Exception(Error(), error)
-import Control.Monad.Error.Class (throwError)
+import Control.Monad.Error.Class (throwError, catchError)
 import Data.Traversable (sequence)
 
 import Database.Postgres.SqlValue
@@ -130,6 +132,27 @@ withClient :: forall eff a
   -> Aff (db :: DB | eff) a
 withClient info p = runFn2 _withClient (mkConnectionString info) p
 
+-- | Runs an asynchronous action in a database transaction. The transaction
+-- | will be rolled back if the computation fails and committed otherwise.
+-- |
+-- | Here the first insert will be rolled back:
+-- |
+-- | ```purescript
+-- | moneyTransfer :: forall e. (Client -> Aff e Unit) -> Client -> Aff e Unit
+-- | moneyTransfer = withTransaction $ \c -> do
+-- |   execute_ (Query "insert into accounts ...") c
+-- |   throwError $ error "Something went wrong"
+-- |   execute_ (Query "insert into accounts ...") c
+-- | ```
+withTransaction :: forall eff a. (Client -> Aff (db :: DB | eff) a) -> Client -> Aff (db :: DB | eff) a
+withTransaction act client = do
+  execute_ (Query "BEGIN TRANSACTION") client
+  res <- attempt (act client)
+  either rollback commit res
+    where
+    rollback err = execute_ (Query "ROLLBACK") client *> throwError err
+    commit v = execute_ (Query "COMMIT") client *> pure v
+
 liftError :: forall e a. ForeignError -> Aff e a
 liftError err = throwError $ error (show err)
 

test/Main.purs

@@ -7,6 +7,8 @@ import Control.Monad.Eff
 import Control.Monad.Eff.Class
 import Control.Monad.Cont.Trans
 import Control.Monad.Trans
+import Control.Monad.Error.Class (throwError)
+import Control.Monad.Eff.Exception (error)
 import Data.Array
 import Data.Foldable
 import Data.Either
@@ -26,6 +28,8 @@ main = runAff (trace <<< show) (const $ trace "All ok") $ do
 
   exampleQueries
 
+  exampleTransaction
+
   liftEff $ disconnect
 
 data Artist = Artist
@@ -74,6 +78,17 @@ exampleQueries = withClient connectionInfo $ \c -> do
   artists <- query (Query "select * from artist where name = $1" :: Query Artist) [toSql "Toto"] c
   liftEff $ printRows artists
 
+exampleTransaction :: forall eff. Aff (db :: DB | eff) Unit
+exampleTransaction = withConnection connectionInfo $ \c -> do
+  execute_ (Query "delete from artist") c
+  apathize $ tryInsert c
+  one <- queryOne_ (Query "select * from artist" :: Query Artist) c
+  liftEff $ trace $ show one
+    where
+    tryInsert = withTransaction $ \c -> do
+      execute_ (Query "insert into artist values ('Not there', 1999)") c
+      throwError $ error "fail"
+
 printRows :: forall a eff. (Show a) => [a] -> Eff (trace :: Trace | eff) Unit
 printRows rows = trace $ "result:\n" <> foldMap stringify rows
   where stringify = show >>> flip (<>) "\n"