traction 0.0.1 → 0.1.0
raw patch · 5 files changed
+251/−16 lines, 5 files
Files
- LICENSE +28/−0
- src/Traction/Control.hs +67/−14
- src/Traction/Sql.hs +2/−0
- test/Test/Traction.hs +144/−0
- traction.cabal +10/−2
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright 2017, Mark Hibberd, All Rights Reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ 2. 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.++ 3. 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.
src/Traction/Control.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-} module Traction.Control ( Db (..) , DbError (..)@@ -10,8 +11,12 @@ , DbPoolConfiguration (..) , defaultDbPoolConfiguration , MonadDb (..)+ , transaction+ , transactionT , runDb , runDbT+ , runDbWith+ , runDbWithT , newPool , newPoolWith , newRollbackPool@@ -44,9 +49,18 @@ newtype DbPool = DbPool {- runDbPool :: forall a. Db a -> EitherT DbError IO a+ runDbPool :: forall a. (Postgresql.Connection -> EitherT DbError IO a) -> EitherT DbError IO a } +data TransactionContext =+ InTransaction Postgresql.Connection+ | NotInTransaction DbPool++newtype Db a =+ Db {+ _runDb :: ReaderT TransactionContext (EitherT DbError IO) a+ } deriving (Functor, Applicative, Monad, MonadIO)+ data DbError = DbSqlError Postgresql.Query Postgresql.SqlError | DbQueryError Postgresql.Query Postgresql.QueryError@@ -75,11 +89,6 @@ DbEncodingInvariant q field encoding -> mconcat ["Query could not decode results, expected to be able to decode [", Text.unpack field, "], to type, [", Text.unpack encoding, "], for query: ", show q] -newtype Db a =- Db {- _runDb :: ReaderT Postgresql.Connection (EitherT DbError IO) a- } deriving (Functor, Applicative, Monad, MonadIO)- class MonadIO m => MonadDb m where liftDb :: Db a -> m a @@ -89,18 +98,56 @@ instance MonadDb m => MonadDb (ExceptT e m) where liftDb = lift . liftDb +data WithTransaction =+ WithTransaction+ | WithoutTransaction+ failWith :: DbError -> Db a failWith = Db . lift . left runDb :: DbPool -> Db a -> EitherT DbError IO a runDb pool db =- runDbPool pool db+ runDbWith pool WithTransaction db runDbT :: DbPool -> (DbError -> e) -> EitherT e Db a -> EitherT e IO a runDbT pool handler db =- squash $ mapEitherT (firstEitherT handler . runDb pool) db+ runDbWithT pool WithTransaction handler db +runDbWith :: DbPool -> WithTransaction -> Db a -> EitherT DbError IO a+runDbWith pool tx db =+ runReaderT (_runDb $ case tx of+ WithTransaction ->+ transaction db+ WithoutTransaction ->+ db) $ NotInTransaction pool++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++transaction :: Db a -> Db a+transaction db =+ Db $ ask >>= \cc -> lift $ case cc of+ InTransaction c ->+ runReaderT (_runDb db) (InTransaction c)+ NotInTransaction pool ->+ runDbPool pool $ \c ->+ runReaderT (_runDb db) (InTransaction c)++transactionT :: EitherT e Db a -> EitherT e Db a+transactionT =+ transactional runEitherT newEitherT++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+ InTransaction c ->+ runReaderT (_runDb $ sifter db) (InTransaction c)+ NotInTransaction pool ->+ runDbPool pool $ \c ->+ runReaderT (_runDb $ sifter db) (InTransaction c)+ data DbPoolConfiguration = DbPoolConfiguration { dbPoolStripes :: Int@@ -137,7 +184,9 @@ pure $ DbPool $ \db -> newEitherT $ Pool.withResource pool $ \c -> handle (\(RollbackException e) -> pure $ Left e) $ Postgresql.withTransaction c $ do- r <- runEitherT $ flip runReaderT c $ _runDb (initializer >> db)+ r <- runEitherT $ do+ runReaderT (_runDb initializer) (InTransaction c)+ db c case r of Left e -> do throwM $ RollbackException e@@ -159,19 +208,23 @@ pure $ DbPool $ \db -> newEitherT $ Pool.withResource pool $ \c -> bracket_ (Postgresql.begin c) (Postgresql.rollback c) $ do- runEitherT $ flip runReaderT c $ _runDb (initializer >> db)+ runEitherT $ do+ runReaderT (_runDb initializer) (InTransaction c)+ db c withRollbackSingletonPool :: (MonadMask m, MonadIO m) => ByteString -> (DbPool -> m a) -> m a withRollbackSingletonPool connection action = do c <- liftIO . Postgresql.connectPostgreSQL $ connection bracket_ (liftIO $ Postgresql.begin c) (liftIO $ Postgresql.rollback c) $- action $ DbPool $ \db ->- newEitherT $- runEitherT $ flip runReaderT c $ _runDb db+ action $ DbPool $ \db -> db c withConnection :: Postgresql.Query -> (Postgresql.Connection -> IO a) -> Db a withConnection query f =- Db $ ask >>= lift . safely query . f+ Db $ ask >>= \cc -> case cc of+ InTransaction c ->+ lift . safely query . f $ c+ NotInTransaction pool ->+ lift . runDbPool pool $ \c -> (safely query . f $ c) safely :: Postgresql.Query -> IO a -> EitherT DbError IO a safely query action =
src/Traction/Sql.hs view
@@ -6,6 +6,7 @@ module Traction.Sql ( Only (..) , Binary (..)+ , PGArray (..) , mandatory , mandatory_ , unique@@ -46,6 +47,7 @@ import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple (ToRow, FromRow, Only (..), Binary (..))+import Database.PostgreSQL.Simple.Types (PGArray (..)) import qualified Database.PostgreSQL.Simple as Postgresql import qualified Database.PostgreSQL.Simple.ToField as Postgresql
+ test/Test/Traction.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+module Test.Traction where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Morph (hoist, lift)++import Data.Text (Text)++import Traction.Prelude+import Traction.Control+import Traction.Migration+import Traction.Sql+import Traction.QQ (sql)++import Hedgehog+import qualified Hedgehog.Gen as Gen++import System.IO (IO)++prop_insert_unique :: Property+prop_insert_unique =+ property $ do+ organisation <- forAll genOrganisation+ r <- db $ do+ o1 <- withUniqueCheck $ oinsert organisation+ o2 <- withUniqueCheck $ oinsert organisation+ pure (isUnique o1, isDuplicate o2)+ (True, True) === r++prop_insert_exists :: Property+prop_insert_exists =+ property $ do+ organisation <- forAll genOrganisation+ r <- db $ do+ void $ oinsert organisation+ oexists organisation+ assert r++prop_insert_not_exists :: Property+prop_insert_not_exists =+ property $ do+ organisation <- forAll genOrganisation+ r <- db $ do+ oexists organisation+ assert (not r)++prop_rollback :: Property+prop_rollback =+ property $ do+ pool <- liftIO $ mkPool+ x <- liftIO . runEitherT . runDb pool $ do+ -- NOTE: intentional syntax error+ fmap (== Just True) . values $ unique [sql|+ SELECT_FAUX_PAUX TRUE+ FROM organisation o+ WHERE o.name = ?+ |] (Only True)+ case x of+ Left _ ->+ pure ()+ Right _ ->+ failure++prop_schema :: Property+prop_schema =+ property $ do+ pool <- liftIO $ mkPool+ evalExceptT . hoist lift . runDb pool $ do+ void $ migrate schema+ void $ migrate schema++oexists :: MonadDb m => Text -> m Bool+oexists o =+ fmap (== Just True) . values $ unique [sql|+ SELECT TRUE+ FROM organisation o+ WHERE o.name = ?+ |] (Only o)++oinsert :: MonadDb m => Text -> m Int+oinsert o =+ value $ mandatory [sql|+ INSERT INTO organisation (name)+ VALUES (?)+ RETURNING id+ |] (Only o)++schema :: [Migration]+schema = [+ Migration "create-organisation" [sql|+ CREATE TABLE organisation (+ id serial PRIMARY KEY+ , name text NOT NULL UNIQUE+ )+ |]+ , Migration "create-account" [sql|+ CREATE TABLE account (+ id SERIAL PRIMARY KEY+ , organisation BIGINT NOT NULL REFERENCES organisation(id)+ , email TEXT NOT NULL UNIQUE+ , name TEXT NOT NULL+ , crypted TEXT NOT NULL+ )+ |]+ ]++db :: Db a -> PropertyT IO a+db x = do+ pool <- liftIO mkPool+ evalExceptT . hoist lift . runDb pool $ migrate schema >> x++mkPool :: IO DbPool+mkPool =+ newRollbackPool "dbname=traction_test host=localhost user=traction_test password=traction_test port=5432"++checkDb :: MonadIO m => Group -> m Bool+checkDb group =+ case group of+ Group name properties ->+ checkSequential (Group name ((fmap . fmap) (withTests 5) properties))++genOrganisation :: Gen Text+genOrganisation = do+ cooking <- Gen.element [+ "fried"+ , "diced"+ , "stewed"+ , "broiled"+ ]+ muppet <- Gen.element [+ "kermet"+ , "gonzo"+ , "beaker"+ , "statler"+ , "waldorf"+ ]+ pure $ cooking <> "-" <> muppet++tests :: IO Bool+tests =+ checkDb $$(discover)
traction.cabal view
@@ -1,13 +1,19 @@ name: traction-version: 0.0.1+version: 0.1.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 build-type: Simple+category: Database+synopsis: Tools for postgresql-simple. description: A few tools for using postgresql-simple.+source-repository head+ type: git+ location: https://github.com/markhibberd/traction library default-language: Haskell2010@@ -54,7 +60,9 @@ , text == 1.2.* , traction + other-modules:+ Test.Traction+ ghc-options: -Wall -threaded- -O2