Make PGTransaction a monad transformer

Author: Lane Seppala

README.md

@@ -2,40 +2,65 @@
 
 ## Summary
 
-`postgresql-transactional` is a simple monadic wrapper around the SQL primitives introduced by the [postgresql-simple][psqls] package. It provides simple and predictable semantics for database operations, enforces awareness of Postgres's transactional nature at API boundaries, and obviates the need for transaction boilerplate in SQL queries.
+`postgresql-transactional` is a simple monadic wrapper around the SQL
+primitives introduced by the [postgresql-simple][psqls] package. It provides
+simple and predictable semantics for database operations, enforces awareness of
+Postgres's transactional nature at API boundaries, and obviates the need for
+transaction boilerplate in SQL queries.
 
 ## Details
 
-Though the primitives provided by the [postgresql-simple][psqls] package are fast and powerful, their interface is (by design) very basic: specifically, all query functions take a shared `Connection` parameter and operate in the `IO` monad. 
+Though the primitives provided by the [postgresql-simple][psqls] package are
+fast and powerful, their interface is (by design) very basic: specifically, all
+query functions take a shared `Connection` parameter and operate in the `IO`
+monad. 
 
 ```haskell
 query :: FromRow r => Connection -> Query -> IO [r]
 execute :: ToRow q => Connection -> Query -> q -> IO Int64
 ```
 
-By virtue of the fact that (usually) all queries in a given scope are routed through a single `Connection`, we can abstract away the shared `Connection` parameter by wrapping a `ReaderT Connection` around the `IO` monad:
+By virtue of the fact that (usually) all queries in a given scope are routed
+through a single `Connection`, we can abstract away the shared `Connection`
+parameter by wrapping a `ReaderT Connection` in a monad transformer:
 
 ```haskell
-newtype PGTransaction a = PGTransaction (ReaderT Connection IO a)
-                          deriving (Functor, Applicative, Monad, MonadIO)
+newtype PGTransactionT m a =
+    PGTransactionT (ReaderT Postgres.Connection m a)
+        deriving (Functor, Applicative, Monad, MonadTrans, MonadIO,
+                  MonadReader Postgres.Connection)
+
+type PGTransaction a = PGTransactionT IO a
 ```
 
+In the common case, the `m` parameter will simply be `IO`. The library provides
+the type alias `type PGTransaction a = PGTransactionT IO a` to simplify type
+signatures in these cases.
+
 We can then reimplement our query functions in a more natural fashion:
 
 ```haskell
-query :: FromRow r => Query -> PGTransaction [a]
-execute :: ToRow q => Query -> q -> PGTransaction Int64
+query :: (FromRow r, MonadIO m) => Query -> PGTransactionT m [a]
+execute :: (ToRow q, MonadIO m) => Query -> q -> PGTransactionT m Int64
 ```
 
-And we can then use the [postgresql-simple][psqls] `withTransaction` function to provide `runPGTransaction`, which executes a given `PGTransaction` block with rollback semantics:
+And we can then use the [postgresql-simple][psqls] `withTransaction` function
+to provide `runPGTransaction`, which executes a given `PGTransactionT` block
+with rollback semantics:
 
 ```haskell
-runPGTransaction :: MonadIO m => PGTransaction a -> Postgres.Connection -> m a
+runPGTransaction :: MonadBaseControl IO m => PGTransactionT m a -> Postgres.Connection -> m a
 ```
 
+Use of the `MonadBaseControl IO m` constraint leaves open the option of
+embedding additional effects with the `m` parameter, such as logging, state, or
+error-handling.
+
 ## About
 
-`postgresql-transactional` was extracted from a production Haskell project at [Helium][helium]. It is open-source software © Helium Systems, Inc., and released to the public under the terms of the MIT license.
+`postgresql-transactional` was extracted from a production Haskell project at
+[Helium][helium]. It is open-source software © Helium Systems, Inc., and
+released to the public under the terms of the MIT license.
 
 [psqls]: https://github.com/lpsmith/postgresql-simple
 [helium]: https://www.helium.com

postgresql-transactional.cabal

@@ -1,5 +1,5 @@
 name:                postgresql-transactional
-version:             0.1.0.0
+version:             0.2.0.0
 synopsis:            a transactional monad on top of postgresql-simple
 license:             MIT
 license-file:        LICENSE
@@ -22,5 +22,6 @@ library
   build-depends:       base >= 4 && < 5
                      , postgresql-simple >= 0.4
                      , mtl
+                     , monad-control
   -- hs-source-dirs:
   default-language:    Haskell2010

src/Database/PostgreSQL/TransactionalStore.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                        #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
@@ -7,6 +8,7 @@ module Database.PostgreSQL.TransactionalStore
     ( PGTransaction
     , runPGTransaction
     , runPGTransaction'
+    , runPGTransactionIO
     , query
     , query_
     , execute
@@ -21,74 +23,106 @@ module Database.PostgreSQL.TransactionalStore
 import           Control.Applicative
 #endif
 import           Control.Monad.Reader
+import           Control.Monad.Trans.Control
 import           Data.Int
-import qualified Database.PostgreSQL.Simple         as Postgres
-import qualified Database.PostgreSQL.Simple.Transaction as Postgres.Transaction
-import qualified Database.PostgreSQL.Simple.Types   as PGTypes
+import qualified Database.PostgreSQL.Simple             as Postgres
 import           Database.PostgreSQL.Simple.FromRow
 import           Database.PostgreSQL.Simple.ToRow
+import qualified Database.PostgreSQL.Simple.Transaction as Postgres.Transaction
+import qualified Database.PostgreSQL.Simple.Types       as PGTypes
 
-newtype PGTransaction a =
-    PGTransaction (ReaderT Postgres.Connection IO a)
+newtype PGTransactionT m a =
+    PGTransactionT (ReaderT Postgres.Connection m a)
     deriving ( Functor
              , Applicative
              , Monad
-             , MonadIO
+             , MonadTrans
              , MonadReader Postgres.Connection
+             , MonadIO
              )
 
-runPGTransaction' :: MonadIO m
+type PGTransaction = PGTransactionT IO
+
+runPGTransaction' :: MonadBaseControl IO m
                   => Postgres.Transaction.IsolationLevel
-                  -> PGTransaction a
+                  -> PGTransactionT m a
                   -> Postgres.Connection -> m a
-runPGTransaction' isolation (PGTransaction pgTrans) conn =
-    liftIO (Postgres.Transaction.withTransactionLevel isolation  conn (runReaderT pgTrans conn))
+runPGTransaction' isolation (PGTransactionT pgTrans) conn =
+    let runTransaction run =
+          Postgres.Transaction.withTransactionLevel isolation conn (run pgTrans)
+    in control runTransaction `runReaderT` conn
 
-runPGTransaction :: MonadIO m => PGTransaction a -> Postgres.Connection -> m a
+runPGTransaction :: MonadBaseControl IO m
+                 => PGTransactionT m a
+                 -> Postgres.Connection
+                 -> m a
 runPGTransaction = runPGTransaction' Postgres.Transaction.DefaultIsolationLevel
 
+
+-- | Convenience function when there are no embedded monadic effects, only IO.
+runPGTransactionIO :: MonadIO m
+                   => PGTransaction a
+                   -> Postgres.Connection
+                   -> m a
+runPGTransactionIO = (liftIO .) . runPGTransaction
+
+
 -- | Issue an SQL query, taking a 'ToRow' input and yielding 'FromRow' outputs.
-query :: (ToRow input, FromRow output)
+query :: (ToRow input, FromRow output, MonadIO m)
       => Postgres.Query
       -> input
-      -> PGTransaction [output]
+      -> PGTransactionT m [output]
 query q params = ask >>= (\conn -> liftIO $ Postgres.query conn q params)
 
 -- | As 'query', but for queries that take no arguments.
-query_ :: (FromRow output) => Postgres.Query -> PGTransaction [output]
+query_ :: (FromRow output, MonadIO m)
+       => Postgres.Query
+       -> PGTransactionT m [output]
 query_ q = ask >>= liftIO . (`Postgres.query_` q)
 
 -- | Run a single SQL action and return success.
-execute :: ToRow input => Postgres.Query -> input -> PGTransaction Int64
-execute q params = ask >>=  (\conn -> liftIO $ Postgres.execute conn q params)
+execute :: (ToRow input, MonadIO m)
+        => Postgres.Query
+        -> input
+        -> PGTransactionT m Int64
+execute q params = ask >>= (\conn -> liftIO $ Postgres.execute conn q params)
 
-executeMany :: ToRow input => Postgres.Query -> [input] -> PGTransaction Int64
-executeMany q params = ask >>=  (\conn -> liftIO $ Postgres.executeMany conn q params)
+executeMany :: (ToRow input, MonadIO m)
+            => Postgres.Query
+            -> [input]
+            -> PGTransactionT m Int64
+executeMany q params = ask >>= (\conn -> liftIO $ Postgres.executeMany conn q params)
 
-returning :: (ToRow input, FromRow output)
+returning :: (ToRow input, FromRow output, MonadIO m)
           => Postgres.Query
           -> [input]
-          -> PGTransaction [output]
+          -> PGTransactionT m [output]
 returning q params = ask >>= (\conn -> liftIO $ Postgres.returning conn q params)
 
 -- | Run a query and return 'Just' the first result found or 'Nothing'.
-queryHead :: (ToRow input, FromRow output)
+queryHead :: (ToRow input, FromRow output, MonadIO m)
           => input
           -> Postgres.Query
-          -> PGTransaction (Maybe output)
+          -> PGTransactionT m (Maybe output)
 queryHead params q = do
   results <- query q params
   return $ case results of
     (a:_) -> Just a
     _     -> Nothing
 
 -- | Run a statement and return 'True' if only a single record was modified.
-executeOne :: (ToRow input) => input -> Postgres.Query -> PGTransaction Bool
+executeOne :: (ToRow input, MonadIO m)
+           => input
+           -> Postgres.Query
+           -> PGTransactionT m Bool
 executeOne params q = do
   results <- execute q params
   return (results == 1)
 
-formatQuery :: ToRow q => Postgres.Query -> q -> PGTransaction Postgres.Query
+formatQuery :: (ToRow q, MonadIO m)
+            => Postgres.Query
+            -> q
+            -> PGTransactionT m Postgres.Query
 formatQuery q params = do
     conn <- ask
     liftIO (PGTypes.Query <$> Postgres.formatQuery conn q params)