├── .gitignore ├── CONTRIBUTING.md ├── CONTRIBUTORS.md ├── LICENSE.txt ├── README.md ├── Setup.hs ├── postgresql-transactional.cabal ├── src └── Database │ └── PostgreSQL │ ├── Tagged.hs │ └── Transaction.hs ├── stack.yaml └── tests ├── Database └── PostgreSQL │ └── TransactionSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | .stack-work 3 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | ## Contributing 2 | 3 | We value contributions from the community and will do everything we can go get them reviewed in a timely fashion. If you have code to send our way or a bug to report: 4 | 5 | * **Contributing Code**: If you have new code or a bug fix, fork this repo, create a logically-named branch, and [submit a PR against this repo](https://github.com/helium/postgresql-transactional/issues). Include a write up of the PR with details on what it does. 6 | 7 | * **Reporting Bugs**: Open an issue [against this repo](https://github.com/helium/postgresql-transactional/issues) with as much detail as you can. At the very least you'll include steps to reproduce the problem. 8 | 9 | This project is intended to be a safe, welcoming space for collaboration, and contributors are expected to adhere to the [Contributor Covenant Code of Conduct](http://contributor-covenant.org/). 10 | 11 | Above all, thank you for taking the time to be a part of the Helium community. -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | **This is a list of people who have contributed to postgresql-transactional:** 2 | 3 | - Reid Draper 4 | - Patrick Thomson 5 | - Lane Sppala 6 | - Jonathan Fischoff -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright 2016 - Helium Systems, Inc. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | 9 | * Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 13 | * Neither the name of the copyright holder nor the 14 | names of its contributors may be used to endorse or promote products 15 | derived from this software without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE 21 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 22 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 23 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 24 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 25 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 26 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 27 | POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # postgresql-transactional 2 | 3 | ## Summary 4 | 5 | `postgresql-transactional` is a simple monadic wrapper around the SQL 6 | primitives introduced by the [postgresql-simple][psqls] package. It provides 7 | simple and predictable semantics for database operations, enforces awareness of 8 | Postgres's transactional nature at API boundaries, and obviates the need for 9 | transaction boilerplate in SQL queries. 10 | 11 | ## Details 12 | 13 | Though the primitives provided by the [postgresql-simple][psqls] package are 14 | fast and powerful, their interface is (by design) very basic: specifically, all 15 | query functions take a shared `Connection` parameter and operate in the `IO` 16 | monad. 17 | 18 | ```haskell 19 | query :: FromRow r => Connection -> Query -> IO [r] 20 | execute :: ToRow q => Connection -> Query -> q -> IO Int64 21 | ``` 22 | 23 | By virtue of the fact that (usually) all queries in a given scope are routed 24 | through a single `Connection`, we can abstract away the shared `Connection` 25 | parameter by wrapping a `ReaderT Connection` in a monad transformer: 26 | 27 | ```haskell 28 | newtype PGTransactionT m a = 29 | PGTransactionT (ReaderT Postgres.Connection m a) 30 | deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, 31 | MonadReader Postgres.Connection) 32 | 33 | type PGTransaction a = PGTransactionT IO a 34 | ``` 35 | 36 | In the common case, the `m` parameter will simply be `IO`. The library provides 37 | the type alias `type PGTransaction a = PGTransactionT IO a` to simplify type 38 | signatures in these cases. 39 | 40 | We can then reimplement our query functions in a more natural fashion: 41 | 42 | ```haskell 43 | query :: (FromRow r, MonadIO m) => Query -> PGTransactionT m [a] 44 | execute :: (ToRow q, MonadIO m) => Query -> q -> PGTransactionT m Int64 45 | ``` 46 | 47 | And we can then use the [postgresql-simple][psqls] `withTransaction` function 48 | to provide `runPGTransaction`, which executes a given `PGTransactionT` block 49 | with rollback semantics: 50 | 51 | ```haskell 52 | runPGTransaction :: MonadBaseControl IO m => PGTransactionT m a -> Postgres.Connection -> m a 53 | ``` 54 | 55 | Use of the `MonadBaseControl IO m` constraint leaves open the option of 56 | embedding additional effects with the `m` parameter, such as logging, state, or 57 | error-handling. 58 | 59 | We also provide a `PGTagged` monad transformer that is equivalent to `PGTransaction`, but includes 60 | a phantom type in each relevant type signature that indicates whether said function has read-only 61 | or write-enabled effects. This can be useful when dispatching read-only queries to Postgres replicas. 62 | 63 | ## Helium Documentation and Community Support 64 | 65 | 66 | * **Docs** Complete documenation for all parts of Helium can be found at [docs.helium.com](https://docs/helium.com). 67 | 68 | * **chat.helium.com** - If you have questions or ideas about how to use this code - or any part of Helium - head over the [chat.helium.com](https://chat.helium.com). We're standing by to help. 69 | 70 | 71 | ## About 72 | 73 | `postgresql-transactional` was extracted from a production Haskell project at 74 | [Helium][helium]. It is open-source software © Helium Systems, Inc., and 75 | released to the public under the terms of the MIT license. 76 | 77 | [psqls]: https://github.com/lpsmith/postgresql-simple 78 | [helium]: https://www.helium.com 79 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /postgresql-transactional.cabal: -------------------------------------------------------------------------------- 1 | name: postgresql-transactional 2 | version: 1.3.1 3 | synopsis: a transactional monad on top of postgresql-simple 4 | license: MIT 5 | license-file: LICENSE.txt 6 | author: Reid Draper and Patrick Thomson 7 | maintainer: patrick@helium.com 8 | copyright: 2015 Helium 9 | category: Database 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | description: 13 | This package is a simple monadic wrapper around the SQL primitives 14 | provided by the postgresql-simple package. It provides simple and 15 | predictable semantics for database options, enforces awareness of 16 | Postgres's transactional nature at API boundaries, and obviates 17 | the need for SQL boilerplate in transactional queries. 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/helium/postgresql-transactional.git 22 | 23 | library 24 | exposed-modules: Database.PostgreSQL.Transaction 25 | , Database.PostgreSQL.Tagged 26 | hs-source-dirs: src 27 | ghc-options: -Wall 28 | -- other-extensions: 29 | build-depends: base >= 4 && < 5 30 | , exceptions 31 | , monad-control 32 | , mtl 33 | , postgresql-simple >= 0.4 34 | default-language: Haskell2010 35 | 36 | test-suite unit-tests 37 | type: exitcode-stdio-1.0 38 | main-is: Spec.hs 39 | 40 | other-modules: Database.PostgreSQL.TransactionSpec 41 | 42 | hs-source-dirs: tests 43 | ghc-options: -Wall 44 | default-language: Haskell2010 45 | 46 | Build-Depends: base 47 | , bytestring 48 | , exceptions 49 | , hspec 50 | , postgresql-simple 51 | , postgresql-transactional 52 | , process 53 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Tagged.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE ImplicitPrelude #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | 10 | {-| 11 | Module : Database.PostgreSQL.Tagged 12 | Copyright : (c) Helium Systems, Inc. 13 | License : MIT 14 | Maintainer : patrick@helium.com 15 | Stability : experimental 16 | Portability : GHC 17 | 18 | This module is similar to @Database.PostgreSQL.Simple@, with one notable exception: 19 | each function is tagged (using DataKinds over the 'Effect' type) with information 20 | as to whether it reads from or writes to the database. This is useful in conjunction 21 | with Postgres setups that are replicated over multiple machines. 22 | 23 | As with @Database.PostgreSQL.Transaction@, the parameter order is reversed when compared to the functions 24 | provided by postgresql-simple. 25 | 26 | -} 27 | 28 | module Database.PostgreSQL.Tagged 29 | ( Effect (..) 30 | , PGTaggedT 31 | , PGTaggedIO 32 | , whileWriting 33 | , runPGWrite 34 | , runPGRead 35 | , query 36 | , query_ 37 | , execute 38 | , executeOne 39 | , executeMany 40 | , returning 41 | , queryHead 42 | , queryOnly 43 | , formatQuery 44 | ) where 45 | 46 | #if __GLASGOW_HASKELL__ < 710 47 | import Control.Applicative 48 | #endif 49 | import Control.Monad.Reader 50 | import Control.Monad.Trans.Control 51 | import Data.Coerce 52 | import Data.Int 53 | import qualified Database.PostgreSQL.Simple as Postgres 54 | import Database.PostgreSQL.Simple.FromField 55 | import Database.PostgreSQL.Simple.FromRow 56 | import Database.PostgreSQL.Simple.ToRow 57 | import qualified Database.PostgreSQL.Transaction as T 58 | 59 | -- | Postgres queries are either read-only or writing-enabled. 60 | -- These values' kinds are used as phantom types in the 'PGTaggedT' 61 | -- monad transformer. 62 | data Effect = Read | Write 63 | 64 | -- | The tagged-effect Postgres monad transformer. 65 | -- The @e@ parameter must be either 'Read' or 'Write'. 66 | newtype PGTaggedT (e :: Effect) m a = 67 | PGTagged (T.PGTransactionT m a) 68 | deriving ( Functor 69 | , Applicative 70 | , Monad 71 | , MonadTrans 72 | , MonadIO) 73 | 74 | -- | A convenient alias for PGTaggedT values taking place in IO. 75 | type PGTaggedIO e a = PGTaggedT e IO a 76 | 77 | -- | Run a writing-oriented PGTagged transaction. 78 | runPGWrite :: MonadBaseControl IO m 79 | => PGTaggedT 'Write m a 80 | -> Postgres.Connection 81 | -> m a 82 | runPGWrite = T.runPGTransactionT . coerce 83 | 84 | -- | Run a read-only PGTagged transaction. Actions such as 85 | -- these can take place on a read-only replica. 86 | runPGRead :: MonadBaseControl IO m 87 | => PGTaggedT 'Read m a 88 | -> Postgres.Connection 89 | -> m a 90 | runPGRead = T.runPGTransactionT . coerce 91 | 92 | -- | Promote a reading operation to a writing operation. 93 | -- Note that there is no way to go the opposite direction 94 | -- (unless you use 'coerce'). This is by design: if you're 95 | -- writing, it's safe to read, but the converse does not 96 | -- necessarily hold true. 97 | whileWriting :: PGTaggedT 'Read m a -> PGTaggedT 'Write m a 98 | whileWriting = coerce 99 | 100 | -- | Run an individual query. (read operation) 101 | query :: (ToRow input, FromRow output, MonadIO m) 102 | => input 103 | -> Postgres.Query 104 | -> PGTaggedT 'Read m [output] 105 | query i = PGTagged <$> T.query i 106 | 107 | -- | As 'query', but without arguments. (read operation) 108 | query_ :: (FromRow output, MonadIO m) 109 | => Postgres.Query 110 | -> PGTaggedT 'Read m [output] 111 | query_ = PGTagged <$> T.query_ 112 | 113 | -- | As 'Database.PostgreSQL.Simple.execute'. (write operation) 114 | execute :: (ToRow input, MonadIO m) 115 | => input 116 | -> Postgres.Query 117 | -> PGTaggedT 'Write m Int64 118 | execute i = PGTagged <$> T.execute i 119 | 120 | -- | As 'Database.PostgreSQL.Simple.executeMany'. (write operation) 121 | executeMany :: (ToRow input, MonadIO m) 122 | => [input] 123 | -> Postgres.Query 124 | -> PGTaggedT 'Write m Int64 125 | executeMany is = PGTagged <$> T.executeMany is 126 | 127 | -- | As 'Database.PostgreSQL.Simple.returning'. (write operation) 128 | returning :: (ToRow input, FromRow output, MonadIO m) 129 | => [input] 130 | -> Postgres.Query 131 | -> PGTaggedT 'Write m [output] 132 | returning is = PGTagged <$> T.returning is 133 | 134 | -- | As 'Database.PostgreSQL.Transaction.queryOnly'. (read operation) 135 | queryOnly :: (ToRow input, FromField f, MonadIO m) 136 | => input 137 | -> Postgres.Query 138 | -> PGTaggedT 'Read m (Maybe f) 139 | queryOnly i = PGTagged <$> T.queryOnly i 140 | 141 | -- | As 'Database.PostgreSQL.Transaction.queryHead'. (read operation) 142 | queryHead :: (ToRow input, FromRow output, MonadIO m) 143 | => input 144 | -> Postgres.Query 145 | -> PGTaggedT 'Read m (Maybe output) 146 | queryHead i = PGTagged <$> T.queryHead i 147 | 148 | -- | As 'Database.PostgreSQL.Transaction.executeOne'. (write operation) 149 | executeOne :: (ToRow input, MonadIO m) 150 | => input 151 | -> Postgres.Query 152 | -> PGTaggedT 'Write m Bool 153 | executeOne i = PGTagged <$> T.executeOne i 154 | 155 | -- | As 'Database.PostgreSQL.Simple.formatQuery'. (neutral) 156 | formatQuery :: (ToRow input, MonadIO m) 157 | => input 158 | -> Postgres.Query 159 | -> PGTaggedT e m Postgres.Query 160 | formatQuery i = PGTagged <$> T.formatQuery i 161 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Transaction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE ImplicitPrelude #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | {-| 10 | Module : Database.PostgreSQL.Transaction 11 | Copyright : (c) Helium Systems, Inc. 12 | License : MIT 13 | Maintainer : patrick@helium.com 14 | Stability : experimental 15 | Portability : GHC 16 | 17 | This module provdes querying with and executing SQL statements that replace 18 | the ones found in @Database.PostgreSQL.Simple@. 19 | 20 | Please note that the parameter order is reversed when compared to the functions 21 | provided by postgresql-simple. This is a conscious choice made so as to ease 22 | use of a SQL quasiquoter. 23 | 24 | -} 25 | 26 | module Database.PostgreSQL.Transaction 27 | ( PGTransactionT 28 | , PGTransaction 29 | , runPGTransactionT 30 | , runPGTransactionT' 31 | , runPGTransactionIO 32 | , mapPGTransactionT 33 | , query 34 | , query_ 35 | , execute 36 | , execute_ 37 | , executeOne 38 | , executeMany 39 | , returning 40 | , queryHead 41 | , queryOnly 42 | , formatQuery 43 | ) where 44 | 45 | #if __GLASGOW_HASKELL__ < 710 46 | import Control.Applicative 47 | #endif 48 | import Control.Monad.Catch 49 | import Control.Monad.Reader 50 | import Control.Monad.State 51 | import Control.Monad.Trans.Control 52 | import Data.Int 53 | import qualified Database.PostgreSQL.Simple as Postgres 54 | import Database.PostgreSQL.Simple.FromField 55 | import Database.PostgreSQL.Simple.FromRow 56 | import Database.PostgreSQL.Simple.ToRow 57 | import qualified Database.PostgreSQL.Simple.Transaction as PT 58 | import qualified Database.PostgreSQL.Simple.Types as PGTypes 59 | 60 | -- | The Postgres transaction monad transformer. This is implemented as a monad transformer 61 | -- so as to integrate properly with monadic logging libraries like @monad-logger@ or @katip@. 62 | newtype PGTransactionT m a = 63 | PGTransactionT { unPGTransactionT :: ReaderT Postgres.Connection m a } 64 | deriving ( Functor 65 | , Applicative 66 | , Monad 67 | , MonadTrans 68 | , MonadIO 69 | , MonadThrow 70 | ) 71 | 72 | 73 | instance MonadReader r m => MonadReader r (PGTransactionT m) where 74 | ask = lift ask 75 | local = mapPGTransactionT . local 76 | 77 | instance MonadState s m => MonadState s (PGTransactionT m) where 78 | get = lift get 79 | put = lift . put 80 | 81 | -- | 'Control.Monad.Catch.catch' is transaction safe and implemented using 82 | -- savepoints: 83 | -- . 84 | -- Savepoints might have a noticable performance impact. The savepoints 85 | -- are released when the transaction finishes or when the catch action and 86 | -- handler finish execution, whichever is first. Savepoints are only used 87 | -- if 'Control.Monad.Catch.catch' or a 'Control.Monad.Catch.catch' derived 88 | -- function such as 'handle' is invoked. 89 | instance (MonadIO m, MonadThrow m, MonadMask m, MonadCatch m) 90 | => MonadCatch (PGTransactionT m) where 91 | -- First we mask exceptions until our exception handler is in place 92 | catch (PGTransactionT act) handler = PGTransactionT $ mask $ \restore -> do 93 | conn <- ask 94 | sp <- liftIO $ PT.newSavepoint conn 95 | -- We restore exceptions after we install a handler that will 96 | -- rollback to the savepoint we just made 97 | let setup = catch (restore act) 98 | $ \e -> case fromException e of 99 | Nothing -> throwM e 100 | Just x -> do 101 | liftIO $ PT.rollbackToSavepoint conn 102 | sp 103 | unPGTransactionT $ handler x 104 | 105 | -- Uncondititionally remove the savepoint. Savepoints are 106 | -- removed when the transaction completes, but we want to 107 | -- remove them when they are no longer needed to save 108 | -- resources. 109 | cleanup = liftIO $ PT.releaseSavepoint conn sp `catch` \err -> 110 | if PT.isNoActiveTransactionError err 111 | || PT.isFailedTransactionError err 112 | then -- The transaction was aborted, so 113 | -- the savepoint was deleted. This 114 | -- is not important, so we catch 115 | -- this exception and bury it deep down 116 | -- in the deepest parts of ourselves we 117 | -- show no one ... no one! 118 | return () 119 | else throwM err 120 | 121 | setup `finally` cleanup 122 | 123 | getConnection :: Monad m => PGTransactionT m Postgres.Connection 124 | getConnection = PGTransactionT ask 125 | 126 | 127 | -- | Transform the computation under PGTransactionT 128 | mapPGTransactionT :: (m a -> n b) -> PGTransactionT m a -> PGTransactionT n b 129 | mapPGTransactionT f (PGTransactionT m) = PGTransactionT $ mapReaderT f m 130 | 131 | 132 | -- | A type alias for occurrences of 'PGTransactionT' in the IO monad. 133 | type PGTransaction = PGTransactionT IO 134 | 135 | 136 | -- | Runs a transaction in the base monad @m@ with a provided 'IsolationLevel'. 137 | -- Catching exceptions through 'MonadBaseControl' is not transaction safe. 138 | runPGTransactionT' :: MonadBaseControl IO m 139 | => PT.IsolationLevel 140 | -> PGTransactionT m a 141 | -> Postgres.Connection 142 | -> m a 143 | runPGTransactionT' isolation (PGTransactionT pgTrans) conn = 144 | let runTransaction run = 145 | PT.withTransactionLevel isolation conn (run pgTrans) 146 | in control runTransaction `runReaderT` conn 147 | 148 | -- | As 'runPGTransactionT'', but with the 'DefaultIsolationLevel' isolation level. 149 | runPGTransactionT :: MonadBaseControl IO m 150 | => PGTransactionT m a 151 | -> Postgres.Connection 152 | -> m a 153 | runPGTransactionT = runPGTransactionT' PT.DefaultIsolationLevel 154 | 155 | 156 | -- | Convenience function when there are no embedded monadic effects, only IO. 157 | runPGTransactionIO :: MonadIO m 158 | => PGTransaction a 159 | -> Postgres.Connection 160 | -> m a 161 | runPGTransactionIO = (liftIO .) . runPGTransactionT 162 | 163 | 164 | -- | Issue an SQL query, taking a 'ToRow' input and yielding 'FromRow' outputs. 165 | -- Please note that the parameter order is different from that in the parent 166 | -- postgresql-simple library; this is an intentional choice to improve the aesthetics 167 | -- when using the SQL quasiquoter (making the query parameters come first means that 168 | -- there is more room for the query string). 169 | query :: (ToRow input, FromRow output, MonadIO m) 170 | => input 171 | -> Postgres.Query 172 | -> PGTransactionT m [output] 173 | query params q = getConnection >>= (\conn -> liftIO $ Postgres.query conn q params) 174 | 175 | -- | As 'query', but for queries that take no arguments. 176 | query_ :: (FromRow output, MonadIO m) 177 | => Postgres.Query 178 | -> PGTransactionT m [output] 179 | query_ q = getConnection >>= liftIO . (`Postgres.query_` q) 180 | 181 | -- | Run a single SQL action and return success. 182 | execute :: (ToRow input, MonadIO m) 183 | => input 184 | -> Postgres.Query 185 | -> PGTransactionT m Int64 186 | execute params q = getConnection >>= (\conn -> liftIO $ Postgres.execute conn q params) 187 | 188 | -- | As 'execute', but for queries that take no arguments. 189 | execute_ :: MonadIO m 190 | => Postgres.Query 191 | -> PGTransactionT m Int64 192 | execute_ q = getConnection >>= (\conn -> liftIO $ Postgres.execute_ conn q) 193 | 194 | -- | As 'Database.PostgreSQL.Simple.executeMany', but operating in the transaction monad. 195 | -- If any one of these computations fails, the entire block will be rolled back. 196 | executeMany :: (ToRow input, MonadIO m) 197 | => [input] 198 | -> Postgres.Query 199 | -> PGTransactionT m Int64 200 | executeMany params q = getConnection >>= (\conn -> liftIO $ Postgres.executeMany conn q params) 201 | 202 | -- | Identical to 'Database.PostgreSQL.Simple.returning', save parameter order. 203 | returning :: (ToRow input, FromRow output, MonadIO m) 204 | => [input] 205 | -> Postgres.Query 206 | -> PGTransactionT m [output] 207 | returning params q = getConnection >>= (\conn -> liftIO $ Postgres.returning conn q params) 208 | 209 | -- | Run a query and return 'Just' the first result found or 'Nothing'. 210 | queryHead :: (ToRow input, FromRow output, MonadIO m) 211 | => input 212 | -> Postgres.Query 213 | -> PGTransactionT m (Maybe output) 214 | queryHead params q = do 215 | results <- query params q 216 | return $ case results of 217 | (a:_) -> Just a 218 | _ -> Nothing 219 | 220 | -- | Run a statement and return 'True' if only a single record was modified. 221 | executeOne :: (ToRow input, MonadIO m) 222 | => input 223 | -> Postgres.Query 224 | -> PGTransactionT m Bool 225 | executeOne params q = (== 1) <$> execute params q 226 | 227 | -- | Lookup a single FromField value. This takes care of handling 'Only' for you. 228 | queryOnly :: (ToRow input, FromField f, MonadIO m) 229 | => input 230 | -> Postgres.Query 231 | -> PGTransactionT m (Maybe f) 232 | queryOnly params q = fmap Postgres.fromOnly <$> queryHead params q 233 | 234 | -- | As 'Database.PostgreSQL.Simple.formatQuery', save parameter order. 235 | formatQuery :: (ToRow input, MonadIO m) 236 | => input 237 | -> Postgres.Query 238 | -> PGTransactionT m Postgres.Query 239 | formatQuery params q = do 240 | conn <- getConnection 241 | liftIO (PGTypes.Query <$> Postgres.formatQuery conn q params) 242 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-3.12 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Control whether we use the GHC we find on the path 17 | # system-ghc: true 18 | 19 | # Require a specific version of stack, using version ranges 20 | # require-stack-version: -any # Default 21 | # require-stack-version: >= 0.1.4.0 22 | 23 | # Override the architecture used by stack, especially useful on Windows 24 | # arch: i386 25 | # arch: x86_64 26 | 27 | # Extra directories used by stack for building 28 | # extra-include-dirs: [/path/to/dir] 29 | # extra-lib-dirs: [/path/to/dir] 30 | -------------------------------------------------------------------------------- /tests/Database/PostgreSQL/TransactionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | module Database.PostgreSQL.TransactionSpec where 5 | 6 | import Control.Monad (void) 7 | import Control.Monad.Catch 8 | import qualified Data.ByteString.Char8 as BSC 9 | import Data.String 10 | import Data.Typeable 11 | import qualified Database.PostgreSQL.Simple as PS 12 | import Database.PostgreSQL.Simple ( Connection 13 | , Only (..) 14 | , SqlError (..) 15 | ) 16 | import Database.PostgreSQL.Simple.SqlQQ 17 | import Database.PostgreSQL.Transaction 18 | import System.Process 19 | import Test.Hspec 20 | 21 | ------------------------- Test DB Creation ------------------------- 22 | createDB :: IO Connection 23 | createDB = do 24 | connectionString <- readProcess "pg_tmp" [] [] 25 | connection <- PS.connectPostgreSQL $ BSC.pack connectionString 26 | void $ PS.execute_ connection $ fromString 27 | [sql| CREATE TABLE fruit (name VARCHAR(100) PRIMARY KEY ) |] 28 | return connection 29 | 30 | ------------------------- Test Utilities ------------------------- 31 | insertFruit :: String -> PGTransactionT IO () 32 | insertFruit fruit 33 | = void 34 | $ execute (Only fruit) 35 | $ fromString [sql| INSERT INTO fruit (name) VALUES (?) |] 36 | 37 | fruits :: Connection -> IO [String] 38 | fruits conn 39 | = fmap (map fromOnly) 40 | $ PS.query_ conn 41 | $ fromString [sql|SELECT name FROM fruit ORDER BY name|] 42 | 43 | runDB :: Connection -> PGTransaction a -> IO a 44 | runDB = flip runPGTransactionIO 45 | 46 | shouldBeM :: (Eq a, Show a) => IO a -> a -> IO () 47 | shouldBeM action expected = do 48 | actual <- action 49 | actual `shouldBe` expected 50 | 51 | -- Simple exception type for testing 52 | data Forbidden = Forbidden 53 | deriving (Show, Eq, Typeable) 54 | 55 | instance Exception Forbidden 56 | 57 | ------------------------- Tests Start ------------------------- 58 | spec :: Spec 59 | spec = describe "TransactionSpec" $ do 60 | -- Notice the 'beforeAll'. The second test uses the same db as the first 61 | beforeAll createDB $ do 62 | it "execute_ happen path succeeds" $ \conn -> do 63 | let apple = "apple" 64 | runDB conn $ insertFruit apple 65 | 66 | fruits conn `shouldBeM` ["apple"] 67 | 68 | it "execute_ rollbacks on exception" $ \conn -> do 69 | flip shouldThrow (\(SqlError {}) -> True) $ 70 | runDB conn $ do 71 | insertFruit "orange" 72 | -- This should cause an exception because of the UNIQUE 73 | -- constraint on 'name' 74 | insertFruit "apple" 75 | 76 | fruits conn `shouldBeM` ["apple"] 77 | 78 | before createDB $ do 79 | it "multiple execute_'s succeed" $ \conn -> do 80 | runDB conn $ do 81 | insertFruit "grapes" 82 | insertFruit "orange" 83 | 84 | fruits conn `shouldBeM` ["grapes", "orange"] 85 | 86 | it "throwM causes a rollback" $ \conn -> do 87 | flip shouldThrow (\Forbidden -> True) $ 88 | runDB conn $ do 89 | insertFruit "salak" 90 | () <- throwM Forbidden 91 | insertFruit "banana" 92 | 93 | fruits conn `shouldBeM` [] 94 | 95 | it "query recovers when exception is caught" $ \conn -> do 96 | runDB conn $ do 97 | -- This should always happen because of the handle below 98 | insertFruit "banana" 99 | handle (\Forbidden -> insertFruit "tomato") $ do 100 | insertFruit "salak" 101 | throwM Forbidden 102 | 103 | fruits conn `shouldBeM` ["banana", "tomato"] 104 | 105 | it "multiple catch statements work correctly" $ \conn -> do 106 | runDB conn $ do 107 | insertFruit "banana" 108 | handle (\Forbidden -> insertFruit "tomato") $ do 109 | -- This will happen ... even if there is an exception below 110 | -- if we catch it 111 | insertFruit "blueberry" 112 | handle (\Forbidden -> insertFruit "frankenberry") $ do 113 | insertFruit "salak" 114 | throwM Forbidden 115 | 116 | fruits conn `shouldBeM` ["banana", "blueberry", "frankenberry"] 117 | 118 | it "alternate branches can also have savepoints" $ \conn -> do 119 | runDB conn $ do 120 | insertFruit "banana" 121 | catch (insertFruit "tomato" >> throwM Forbidden) $ 122 | \Forbidden -> do 123 | insertFruit "blueberry" 124 | handle (\Forbidden -> insertFruit "frankenberry") $ do 125 | insertFruit "salak" 126 | throwM Forbidden 127 | 128 | fruits conn `shouldBeM` ["banana", "blueberry", "frankenberry"] 129 | 130 | it "releasing silently fails if the transaction errors" $ \conn -> do 131 | runDB conn $ do 132 | insertFruit "banana" 133 | catchAll (void $ execute_ $ fromString [sql| ABORT |]) $ 134 | \_ -> insertFruit "tomato" 135 | 136 | fruits conn `shouldBeM` [] 137 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | 5 | import qualified Database.PostgreSQL.TransactionSpec as TransactionSpec 6 | 7 | main :: IO () 8 | main = hspec TransactionSpec.spec 9 | --------------------------------------------------------------------------------