traction 0.3.0 → 0.4.0

raw patch · 4 files changed

+97/−27 lines, 4 filesdep ~hedgehogdep ~postgresql-simpledep ~transformers-eitherPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hedgehog, postgresql-simple, transformers-either

API changes (from Hackage documentation)

Files

• src/Traction/Control.hs +59/−16
• src/Traction/Sql.hs +20/−6
• test/Test/Traction.hs +13/−0
• traction.cabal +5/−5

@@ -7,6 +7,7 @@     Db   , DbT (..)   , DbError (..)+  , Tracer   , renderDbError   , DbPool (..)   , DbPoolConfiguration (..)@@ -18,6 +19,10 @@   , runDbT   , runDbWith   , runDbWithT+  , runDbTracing+  , runDbTracingT+  , runDbTracingWith+  , runDbTracingWithT   , newPool   , newPoolWith   , newRollbackPool@@ -25,6 +30,9 @@   , withRollbackSingletonPool   , withConnection   , failWith+  , withTracing+  , trace+  , noTracing   ) where  import           Control.Monad.Catch (Exception, MonadMask (..), MonadThrow, MonadCatch, Handler (..), handle, catches, bracket_, throwM)@@ -32,7 +40,7 @@ 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)+import           Control.Monad.Trans.Reader (ReaderT (..), ask, asks, local)  import           Data.ByteString (ByteString) import           Data.Text (Text)@@ -57,12 +65,23 @@     InTransaction Postgresql.Connection   | NotInTransaction DbPool +data TractionSettings =+  TractionSettings {+      transactionContext :: TransactionContext+    , tracer :: Tracer+    }++type Tracer = Text -> IO ()++noTracing :: Tracer+noTracing = const (pure ())+ type Db =   DbT IO  newtype DbT m a =   DbT {-      _runDb :: ReaderT TransactionContext (EitherT DbError m) a+      _runDb :: ReaderT TractionSettings (EitherT DbError m) a     }  deriving (Functor, Applicative, Monad, MonadIO, MonadMask, MonadThrow, MonadCatch)  instance MFunctor DbT where@@ -126,24 +145,40 @@  runDbWith :: DbPool -> WithTransaction -> Db a -> EitherT DbError IO a runDbWith pool tx db =+  runDbTracingWith pool noTracing tx db++runDbWithT :: DbPool -> WithTransaction -> (DbError -> e) -> EitherT e Db a -> EitherT e IO a+runDbWithT pool tx handler db =+  runDbTracingWithT pool noTracing tx handler db++runDbTracing :: DbPool -> Tracer -> Db a -> EitherT DbError IO a+runDbTracing pool tr db =+  runDbTracingWith pool tr WithTransaction db++runDbTracingT :: DbPool -> Tracer -> (DbError -> e) -> EitherT e Db a -> EitherT e IO a+runDbTracingT pool tr handler db =+  runDbTracingWithT pool tr WithTransaction handler db++runDbTracingWith :: DbPool -> Tracer -> WithTransaction -> Db a -> EitherT DbError IO a+runDbTracingWith pool tr tx db =   runReaderT (_runDb $ case tx of     WithTransaction ->       transaction db     WithoutTransaction ->-      db) $ NotInTransaction pool+      db) $ TractionSettings (NotInTransaction pool) tr -runDbWithT :: DbPool -> WithTransaction -> (DbError -> e) -> EitherT e Db a -> EitherT e IO a-runDbWithT pool tx handler db =-  squash $ mapEitherT (firstEitherT handler . runDbWith pool tx) db+runDbTracingWithT :: DbPool -> Tracer -> WithTransaction -> (DbError -> e) -> EitherT e Db a -> EitherT e IO a+runDbTracingWithT pool tr tx handler db =+  squash $ mapEitherT (firstEitherT handler . runDbTracingWith pool tr tx) db  transaction :: Db a -> Db a transaction db =-  DbT $ ask >>= \cc -> lift $ case cc of-    InTransaction c ->-      runReaderT (_runDb db) (InTransaction c)+  DbT $ ask >>= \cc -> lift $ case transactionContext cc of+    InTransaction _ ->+      runReaderT (_runDb db) cc     NotInTransaction pool ->       runDbPool pool $ \c ->-        runReaderT (_runDb db) (InTransaction c)+        runReaderT (_runDb db) $ TractionSettings (InTransaction c) noTracing  transactionT :: EitherT e Db a -> EitherT e Db a transactionT =@@ -151,12 +186,12 @@  transactional :: (Monad m, Monad n) => (m a -> Db (n a)) -> (Db (n a) -> m a) -> m a -> m a transactional sifter lifter db =-  lifter . DbT $ ask >>= \cc -> lift $ case cc of+  lifter . DbT $ ask >>= \cc -> lift $ case transactionContext cc of     InTransaction c ->-      runReaderT (_runDb $ sifter db) (InTransaction c)+      runReaderT (_runDb $ sifter db) $ TractionSettings (InTransaction c) noTracing     NotInTransaction pool ->       runDbPool pool $ \c ->-        runReaderT (_runDb $ sifter db) (InTransaction c)+        runReaderT (_runDb $ sifter db) $ TractionSettings (InTransaction c) noTracing  data DbPoolConfiguration =   DbPoolConfiguration {@@ -195,7 +230,7 @@     newEitherT $ Pool.withResource pool $ \c ->       handle (\(RollbackException e) -> pure $ Left e) $ Postgresql.withTransaction c $ do         r <- runEitherT $ do-          runReaderT (_runDb initializer) (InTransaction c)+          runReaderT (_runDb initializer) $ TractionSettings (InTransaction c) noTracing           db c         case r of           Left e -> do@@ -219,7 +254,7 @@     newEitherT $ Pool.withResource pool $ \c ->       bracket_ (Postgresql.begin c) (Postgresql.rollback c)  $ do         runEitherT $ do-          runReaderT (_runDb initializer) (InTransaction c)+          runReaderT (_runDb initializer) $ TractionSettings (InTransaction c) noTracing           db c  withRollbackSingletonPool :: (MonadMask m, MonadIO m) => ByteString -> (DbPool -> m a) -> m a@@ -230,11 +265,19 @@  withConnection :: Postgresql.Query -> (Postgresql.Connection -> IO a) -> Db a withConnection query f =-  DbT $ ask >>= \cc -> case cc of+  DbT $ ask >>= \cc -> case transactionContext cc of     InTransaction c ->       lift . safely query . f $ c     NotInTransaction pool ->       lift . runDbPool pool $ \c -> (safely query . f $ c)++withTracing :: Tracer -> DbT m () -> DbT m ()+withTracing f (DbT db) = DbT $ local (\x -> x { tracer = f }) db++trace :: (MonadDb m, Show a) => a -> m ()+trace a =+  liftDb . DbT $ asks tracer >>= \t ->+    liftIO . t . Text.pack $ show a  safely :: Postgresql.Query -> IO a -> EitherT DbError IO a safely query action =

@@ -15,6 +15,8 @@   , query_   , execute   , execute_+  , explain+  , explain_   , value   , valueWith   , values@@ -64,34 +66,46 @@   liftDb . definitely q $ unique_ q  unique :: (MonadDb m, ToRow a, FromRow b) => Postgresql.Query -> a -> m (Maybe b)-unique q parameters =+unique q parameters = do+  trace q   liftDb . possibly q . withConnection q $ \c ->     Postgresql.query c q parameters  unique_ :: (MonadDb m, FromRow a) => Postgresql.Query -> m (Maybe a)-unique_ q =+unique_ q = do+  trace q   liftDb . possibly q . withConnection q $ \c ->     Postgresql.query_ c q  query :: (MonadDb m, ToRow a, FromRow  b) => Postgresql.Query -> a -> m [b]-query q parameters =+query q parameters = do+  trace q   liftDb . withConnection q $ \c ->     Postgresql.query c q parameters  query_ :: (MonadDb m, FromRow a) => Postgresql.Query -> m [a]-query_ q =+query_ q = do+  trace q   liftDb . withConnection q $ \c ->     Postgresql.query_ c q  execute :: (MonadDb m, ToRow a) => Postgresql.Query -> a -> m Int64-execute q parameters =+execute q parameters = do+  trace q   liftDb . withConnection q $ \c ->     Postgresql.execute c q parameters  execute_ :: MonadDb m => Postgresql.Query -> m Int64-execute_ q =+execute_ q = do+  trace q   liftDb . withConnection q $ \c ->     Postgresql.execute_  c q++explain :: (MonadDb m, ToRow a) => Postgresql.Query -> a -> m Text+explain q a = Text.unlines . value <$> query q a++explain_ :: MonadDb m => Postgresql.Query -> m Text+explain_ q = Text.unlines . value <$> query_ q  possibly :: Postgresql.Query -> Db [a] -> Db (Maybe a) possibly q db =

@@ -8,6 +8,7 @@ import           Control.Monad.Morph (hoist, lift)  import           Data.Text (Text)+import qualified Data.Text as Text  import           Traction.Prelude import           Traction.Control@@ -19,6 +20,18 @@ import qualified Hedgehog.Gen as Gen  import           System.IO (IO)++prop_explain :: Property+prop_explain =+  property $ do+    organisation <- forAll genOrganisation+    r <- db $+      explain [sql|+        EXPLAIN INSERT INTO organisation (name)+            VALUES (?)+          RETURNING id+      |] (Only organisation)+    assert (Text.isPrefixOf "Insert on organisation" r)  prop_insert_unique :: Property prop_insert_unique =

@@ -1,5 +1,5 @@ name: traction-version: 0.3.0+version: 0.4.0 license: BSD3 license-file: LICENSE author: Mark Hibberd <mark@hibberd.id.au>@@ -24,14 +24,14 @@     , containers >= 0.5.8 && < 0.7     , exceptions == 0.10.*     , mmorph == 1.*-    , postgresql-simple == 0.5.*+    , postgresql-simple >= 0.5 && < 0.7     , resource-pool == 0.2.*     , syb >= 0.4 && < 0.8     , template-haskell     , text == 1.2.*     , time >= 1.5 && < 1.10     , transformers == 0.5.*-    , transformers-either == 0.0.*+    , transformers-either >= 0 && < 0.2    ghc-options:     -Wall@@ -53,9 +53,9 @@   hs-source-dirs: test   build-depends:       base >= 3 && < 5-    , hedgehog == 0.5.*+    , hedgehog >= 0.5 && < 1.1     , mmorph == 1.*-    , postgresql-simple == 0.5.*+    , postgresql-simple >= 0.5 && < 0.7     , resource-pool == 0.2.*     , text == 1.2.*     , traction