traction 0.2.1 → 0.3.0

raw patch · 3 files changed

+26/−16 lines, 3 files

Files

• src/Traction/Control.hs +22/−12
• src/Traction/Sql.hs +2/−2
• traction.cabal +2/−2

@@ -4,7 +4,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Traction.Control (-    Db (..)+    Db+  , DbT (..)   , DbError (..)   , renderDbError   , DbPool (..)@@ -28,7 +29,7 @@  import           Control.Monad.Catch (Exception, MonadMask (..), MonadThrow, MonadCatch, Handler (..), handle, catches, bracket_, throwM) import           Control.Monad.IO.Class (MonadIO (..))-import           Control.Monad.Morph (squash)+import           Control.Monad.Morph (MFunctor (..), squash) import           Control.Monad.Trans.Class (MonadTrans (..)) import           Control.Monad.Trans.Except (ExceptT(..)) import           Control.Monad.Trans.Reader (ReaderT (..), ask)@@ -56,11 +57,20 @@     InTransaction Postgresql.Connection   | NotInTransaction DbPool -newtype Db a =-  Db {-      _runDb :: ReaderT TransactionContext (EitherT DbError IO) a+type Db =+  DbT IO++newtype DbT m a =+  DbT {+      _runDb :: ReaderT TransactionContext (EitherT DbError m) a     }  deriving (Functor, Applicative, Monad, MonadIO, MonadMask, MonadThrow, MonadCatch) +instance MFunctor DbT where+  hoist f = DbT . hoist (hoist f) . _runDb++instance MonadTrans DbT where+  lift = DbT . lift . lift+ data DbError =     DbSqlError Postgresql.Query Postgresql.SqlError   | DbQueryError Postgresql.Query Postgresql.QueryError@@ -90,10 +100,10 @@       mconcat ["Query could not decode results, expected to be able to decode [", Text.unpack field, "], to type, [", Text.unpack encoding, "], for query: ", show q]  class MonadIO m => MonadDb m where-  liftDb :: Db a -> m a+  liftDb :: DbT IO a -> m a -instance MonadDb Db where-  liftDb = id+instance MonadIO m => MonadDb (DbT m) where+  liftDb = hoist liftIO  instance MonadDb m => MonadDb (ExceptT e m) where   liftDb = lift . liftDb@@ -104,7 +114,7 @@  failWith :: DbError -> Db a failWith =-  Db . lift . left+  DbT . lift . left  runDb :: DbPool -> Db a -> EitherT DbError IO a runDb pool db =@@ -128,7 +138,7 @@  transaction :: Db a -> Db a transaction db =-  Db $ ask >>= \cc -> lift $ case cc of+  DbT $ ask >>= \cc -> lift $ case cc of     InTransaction c ->       runReaderT (_runDb db) (InTransaction c)     NotInTransaction pool ->@@ -141,7 +151,7 @@  transactional :: (Monad m, Monad n) => (m a -> Db (n a)) -> (Db (n a) -> m a) -> m a -> m a transactional sifter lifter db =-  lifter . Db $ ask >>= \cc -> lift $ case cc of+  lifter . DbT $ ask >>= \cc -> lift $ case cc of     InTransaction c ->       runReaderT (_runDb $ sifter db) (InTransaction c)     NotInTransaction pool ->@@ -220,7 +230,7 @@  withConnection :: Postgresql.Query -> (Postgresql.Connection -> IO a) -> Db a withConnection query f =-  Db $ ask >>= \cc -> case cc of+  DbT $ ask >>= \cc -> case cc of     InTransaction c ->       lift . safely query . f $ c     NotInTransaction pool ->

@@ -167,7 +167,7 @@  bracketSavepoint :: Savepoint -> Db a -> Db a bracketSavepoint savepoint db =-  Db $ ask >>= \c -> lift $ do+  DbT $ ask >>= \c -> lift $ do     r <- liftIO . runEitherT $ flip runReaderT c $ _runDb (createSavepoint savepoint >> db)     case r of       Left _ -> do@@ -200,7 +200,7 @@  withUniqueCheckSavepoint :: MonadDb m => Savepoint -> Db a -> m (Unique a) withUniqueCheckSavepoint savepoint db =-  liftDb . Db $ ask >>= \c -> lift $ do+  liftDb . DbT $ ask >>= \c -> lift $ do     r <- liftIO . runEitherT $ flip runReaderT c $ _runDb (bracketSavepoint savepoint db)     case r of       Left (DbSqlError q e) -> do

@@ -1,11 +1,11 @@ name: traction-version: 0.2.1+version: 0.3.0 license: BSD3 license-file: LICENSE author: Mark Hibberd <mark@hibberd.id.au> maintainer: Mark Hibberd <mark@hibberd.id.au> copyright: (c) 2017 Mark Hibberd-cabal-version: >= 1.24+cabal-version: 1.24 build-type: Simple category: Database synopsis: Tools for postgresql-simple.