postgresql-tx 0.1.0.0 → 0.2.0.0

raw patch · 7 files changed

+379/−60 lines, 7 filesnew-uploaderPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• package.yaml +1/−1
• postgresql-tx.cabal +6/−3
• src/Database/PostgreSQL/Tx.hs +33/−56
• src/Database/PostgreSQL/Tx/HEnv.hs +89/−0
• src/Database/PostgreSQL/Tx/Internal.hs +206/−0
• src/Database/PostgreSQL/Tx/Unsafe.hs +35/−0

@@ -1,5 +1,14 @@ # Change log +## 0.2.0.0++* Changed the `TxM` encoding from a plain newtype-over-IO to a reader.+* Removed the `Tx` and `UnsafeTx` type classes.+* `TxEnv` is now a type class. Added `TxEnvs` for convenience.+* Added `TxException`.+* Added the `HEnv` type.+* Changed module structure so that unsafe functions are provided in an `Unsafe` module.+ ## 0.1.0.0  Initial release

@@ -1,5 +1,5 @@ name:                postgresql-tx-version:             0.1.0.0+version:             0.2.0.0 github:              "simspace/postgresql-tx" license:             BSD3 license-file:        LICENSE.md

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: e101ce5ab3c06e184533b8848069104aed53c8b9449a654bac5cb7d9ca3adced+-- hash: 6502ef6d385db187552d31216c423233d2ea504b31a19ce4f273aa8aeb6773c0  name:           postgresql-tx-version:        0.1.0.0+version:        0.2.0.0 synopsis:       A safe transaction monad for use with various PostgreSQL Haskell libraries. description:    Please see the README on GitHub at <https://github.com/simspace/postgresql-tx#readme> category:       Database@@ -32,6 +32,9 @@ library   exposed-modules:       Database.PostgreSQL.Tx+      Database.PostgreSQL.Tx.HEnv+      Database.PostgreSQL.Tx.Internal+      Database.PostgreSQL.Tx.Unsafe   other-modules:       Paths_postgresql_tx   hs-source-dirs:

@@ -1,63 +1,40 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} module Database.PostgreSQL.Tx-  ( TxM(unsafeRunTxM)-  , unsafeRunIOInTxM-  , Tx(TxEnv, tx)-  , UnsafeTx(unsafeIOTx)-  , unsafeReaderIOTx-  ) where--import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Trans.Reader (ReaderT(ReaderT, runReaderT), mapReaderT)-import GHC.TypeLits (ErrorMessage(Text), TypeError)--newtype TxM a = UnsafeTxM { unsafeRunTxM :: IO a }-  deriving newtype (Functor, Applicative, Monad)--instance-  ( TypeError-      ('Text "MonadIO is banned in TxM; use 'unsafeRunIOInTxM' if you are sure this is safe IO")-  ) => MonadIO TxM-  where-  liftIO = undefined--unsafeRunIOInTxM :: IO a -> TxM a-unsafeRunIOInTxM = UnsafeTxM---- | Type class for converting an 'f' to 'TxM' given a 'TxEnv'.-class Tx (f :: * -> *) where-  -- | The runtime environment needed to convert 'f' to 'TxM'.-  type TxEnv f :: *-  -- | Converts an 'f' to a 'TxM'.-  tx :: TxEnv f -> f a -> TxM a+  ( -- * Introduction+    -- $intro -instance Tx (ReaderT r TxM) where-  type TxEnv (ReaderT r TxM) = r-  tx = flip runReaderT+    -- ** Transaction monad+    TxM --- | Promote an unsafe 'io' action to a safe 't' transaction (will be some form of 'TxM').-class UnsafeTx (io :: * -> *) (t :: * -> *) | t -> io where-  -- | Converts an 'io' action to a 't', which will be some form of 'TxM'.-  unsafeIOTx :: io a -> t a+    -- ** Transaction environment+  , TxEnv(lookupTxEnv)+  , TxEnvs+  , askTxEnv -instance UnsafeTx IO TxM where-  unsafeIOTx = unsafeRunIOInTxM+    -- ** Exceptions+  , throwExceptionTx+  , mapExceptionTx+  , TxException(..)+  , TxErrorType(..)+  , shouldRetryTx+  ) where -instance (UnsafeTx io t) => UnsafeTx (ReaderT r io) (ReaderT r t) where-  unsafeIOTx = mapReaderT unsafeIOTx+import Database.PostgreSQL.Tx.Internal --- | Promotes an unsafe 'io' function to some 'ReaderT' over 'TxM'.-unsafeReaderIOTx-  :: (UnsafeTx (ReaderT r io) (ReaderT r t))-  => (r -> io a) -> ReaderT r t a-unsafeReaderIOTx = unsafeIOTx . ReaderT+-- $intro+--+-- @postgresql-tx@ provides a transaction monad - 'TxM'. When arbitrary 'IO' is+-- attempted to be performed within 'TxM', a type error is generated. Arbitrary+-- 'IO' can still be performed when neccessary, but users must explicitly+-- opt-in to this via the "Database.PostgreSQL.Tx.Unsafe" module's @unsafe*@+-- functions.+--+-- Note that @posgresql-tx@ has no dependencies on any specific+-- @postgres@-related database libraries. This library defines the 'TxM' monad+-- and the infrastructure necessary to adapt specific database libraries for+-- 'TxM' compatiblity. The idea is that an adaptor library provides a means to+-- convert a specific database library's implementation monad into 'TxM'.+-- Application authors can then freely mix 'TxM' database functions together+-- even if the implementations of these database functions are using different+-- underlying database libraries, e.g. @postgresql-query@ , @squeal-postgresql@,+-- @postgresql-simple@, etc.

@@ -0,0 +1,89 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Database.PostgreSQL.Tx.HEnv+  ( HEnv(Nil, Cons)+  , singleton+  , fromTuple+  ) where++import Database.PostgreSQL.Tx (TxEnv(lookupTxEnv))++-- | Glorified hlist used to construct ad hoc @tx@ runtime environments.+data family HEnv (l :: [*])+data instance HEnv '[] = Nil+data instance HEnv (x ': xs) = x `Cons` HEnv xs+infixr 2 `Cons`++-- | Construct an 'HEnv' containing a single value.+--+-- @since 0.2.0.0+singleton :: a -> HEnv '[a]+singleton = (`Cons` Nil)++-- | 'TxEnv' instance for 'HEnv'; selects the first @a@ in the 'HEnv'+-- and makes it available via the runtime environment.+--+-- @since 0.2.0.0+instance (Select a xs) => TxEnv a (HEnv xs) where+  lookupTxEnv = select++-- | Internal type class for selecting the first @a@ in an 'HEnv'.+class Select a xs where+  select :: HEnv xs -> a++instance Select a (a ': xs) where+  select (a `Cons` _) = a++instance {-# OVERLAPPABLE #-} (Select a xs) => Select a (x ': xs) where+  select (_ `Cons` xs) = select xs++-- | Internal type class for constructing an 'HEnv' from a tuple.+class FromTuple i o | i -> o where++  -- | Construct an 'HEnv' from the given tuple @i@.+  -- Instances support tuples of up to 16 elements.+  --+  -- @since 0.2.0.0+  fromTuple :: i -> HEnv o++instance FromTuple (x1, x2) '[x1, x2] where fromTuple (x1, x2) = x1 `Cons` x2 `Cons` Nil+instance FromTuple (x1, x2, x3) '[x1, x2, x3] where fromTuple (x1, x2, x3) = x1 `Cons` x2 `Cons` x3 `Cons` Nil+instance FromTuple (x1, x2, x3, x4) '[x1, x2, x3, x4] where fromTuple (x1, x2, x3, x4) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5) '[x1, x2, x3, x4, x5] where fromTuple (x1, x2, x3, x4, x5) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6) '[x1, x2, x3, x4, x5, x6] where fromTuple (x1, x2, x3, x4, x5, x6) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6, x7) '[x1, x2, x3, x4, x5, x6, x7] where fromTuple (x1, x2, x3, x4, x5, x6, x7) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` x7 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6, x7, x8) '[x1, x2, x3, x4, x5, x6, x7, x8] where fromTuple (x1, x2, x3, x4, x5, x6, x7, x8) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` x7 `Cons` x8 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9) '[x1, x2, x3, x4, x5, x6, x7, x8, x9] where fromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` x7 `Cons` x8 `Cons` x9 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10] where fromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` x7 `Cons` x8 `Cons` x9 `Cons` x10 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11] where fromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` x7 `Cons` x8 `Cons` x9 `Cons` x10 `Cons` x11 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12] where fromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` x7 `Cons` x8 `Cons` x9 `Cons` x10 `Cons` x11 `Cons` x12 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13) '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13] where fromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` x7 `Cons` x8 `Cons` x9 `Cons` x10 `Cons` x11 `Cons` x12 `Cons` x13 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14) '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14] where fromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` x7 `Cons` x8 `Cons` x9 `Cons` x10 `Cons` x11 `Cons` x12 `Cons` x13 `Cons` x14 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15] where fromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` x7 `Cons` x8 `Cons` x9 `Cons` x10 `Cons` x11 `Cons` x12 `Cons` x13 `Cons` x14 `Cons` x15 `Cons` Nil+instance FromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16) '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16] where fromTuple (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16) = x1 `Cons` x2 `Cons` x3 `Cons` x4 `Cons` x5 `Cons` x6 `Cons` x7 `Cons` x8 `Cons` x9 `Cons` x10 `Cons` x11 `Cons` x12 `Cons` x13 `Cons` x14 `Cons` x15 `Cons` x16 `Cons` Nil+{- Instances above generated with:+import Data.List+main = do+  flip mapM_ [2..16] $ \i -> do+    let args = flip map [1..i] $ \j -> "x" ++ show j+    let commaSep = intercalate ", " args+    putStrLn $ concat+      [ "instance Mk ("+      , commaSep+      , ") '["+      , commaSep+      , "] where mk ("+      , commaSep+      , ") = "+      , intercalate " `Cons` " (args ++ ["Nil"])+      ]+-}

@@ -0,0 +1,206 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Database.PostgreSQL.Tx.Internal+  ( -- * Disclaimer+    -- $disclaimer++    -- ** Internals+    module Database.PostgreSQL.Tx.Internal+  ) where++import Control.Exception (Exception(toException), SomeException, catch, throwIO)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Trans.Reader (ReaderT(ReaderT, runReaderT))+import Data.Kind (Constraint)+import GHC.TypeLits (ErrorMessage(Text), TypeError)++-- | The transaction monad. Unifies all database integrations, regardless of+-- library, into a single monad. The @r@ type parameter represents the reader+-- environment needed for applicable database libraries. For example,+-- @postgresql-simple@ needs a @Connection@ to run its functions, so+-- its interface will require that we can obtain a @Connection@ from the @r@+-- using the 'TxEnv' type class.+--+-- @since 0.2.0.0+newtype TxM r a = UnsafeTxM+  { -- | Convert a 'TxM' action to raw 'ReaderT' over 'IO'. This is provided only to give+    -- adaptor libraries access to the underlying 'IO' that 'TxM' wraps.+    --+    -- @since 0.2.0.0+    unsafeUnTxM :: ReaderT r IO a+  } deriving newtype (Functor, Applicative, Monad, MonadFail)+    deriving (Semigroup, Monoid) via (r -> IO a)++-- | Run an 'IO' action in 'TxM'. Use this function with care - arbitrary 'IO'+-- should only be run within a transaction when truly necessary.+--+-- @since 0.2.0.0+unsafeRunIOInTxM :: IO a -> TxM r a+unsafeRunIOInTxM = UnsafeTxM . liftIO++-- | Construct a 'TxM' using a reader function. Use this function with care -+-- arbitrary 'IO' should only be run within a transaction when truly necessary.+--+-- @since 0.2.0.0+unsafeMkTxM :: (r -> IO a) -> TxM r a+unsafeMkTxM = UnsafeTxM . ReaderT++-- | Similar to 'unsafeMkTxM' but allows for constructing a 'TxM' with a+-- reader function using a specific value from the environment.+-- Use this function with care - arbitrary 'IO' should only be run+-- within a transaction when truly necessary.+--+-- @since 0.2.0.0+unsafeMksTxM :: (TxEnv a r) => (a -> IO b) -> TxM r b+unsafeMksTxM f =+  unsafeMkTxM \r -> unsafeRunTxM r do+    a <- askTxEnv+    unsafeRunIOInTxM $ f a++-- | The 'TxM' monad discourages performing arbitrary 'IO' within a+-- transaction, so this instance generates a type error when client code tries+-- to call 'liftIO'.+--+-- @since 0.1.0.0+instance+  ( TypeError+      ('Text "MonadIO is banned in TxM; use 'unsafeRunIOInTxM' if you are sure this is safe IO")+  ) => MonadIO (TxM r)+  where+  liftIO = undefined++-- | Run a 'TxM' to 'IO' given the database runtime environment @r@.+-- Use of this function outside of test suites should be rare.+--+-- @since 0.2.0.0+unsafeRunTxM :: r -> TxM r a -> IO a+unsafeRunTxM r x = runReaderT (unsafeUnTxM x) r++-- | Run a 'TxM' action in 'IO' via the provided runner function. Use this+-- function with care - arbitrary 'IO' should only be run within a transaction+-- when truly necessary.+--+-- @since 0.2.0.0+unsafeWithRunInIOTxM :: ((forall a. TxM r a -> IO a) -> IO b) -> TxM r b+unsafeWithRunInIOTxM inner = unsafeMkTxM \r -> inner (unsafeRunTxM r)++-- | A type class for specifying how to acquire an environment value+-- to be used for running an implementation of a database library.+-- For example, your database library will likely require some sort of+-- connection value to discharge its effects; in this case, you'd want to+-- define an instance of @TxEnv MyDBEnv Connection@ and use @TxM MyDBEnv@+-- as your monad for executing transactions.+--+-- Note that implementations should take care and ensure that multiple+-- instances are compatible with one another. For example, let's say you+-- have instances for both @TxEnv E PgSimple.Connection@ and+-- @TxEnv E LibPQ.Connection@; if both of these implementations are grabbing+-- connections from a pool, you will end up with each of those database+-- libraries using different connections, and thus, would be running in+-- separate transactions!+--+-- @since 0.2.0.0+class TxEnv a r where++  -- | Acquire a value @a@ via the reader environment @r@ which assists in+  -- running a 'TxM' in a transaction.+  --+  -- @since 0.2.0.0+  lookupTxEnv :: r -> a++askTxEnv :: (TxEnv a r) => TxM r a+askTxEnv = unsafeMkTxM (pure . lookupTxEnv)++-- | Analogous to 'lookupTxEnv' but can be run in 'IO' instead of 'TxM'.+--+-- @since 0.2.0.0+unsafeLookupTxEnvIO :: (TxEnv a r) => r -> IO a+unsafeLookupTxEnvIO r = unsafeRunTxM r askTxEnv++-- | Type family which allows for specifying several 'TxEnv' constraints as+-- a type-level list.+--+-- @since 0.2.0.0+type family TxEnvs (xs :: [*]) r :: Constraint where+  TxEnvs '[] r = ()+  TxEnvs (x ': xs) r = (TxEnv x r, TxEnvs xs r)++-- | Throw an exception.+--+-- @since 0.2.0.0+throwExceptionTx :: (Exception e) => e -> TxM r a+throwExceptionTx = unsafeRunIOInTxM . throwIO++-- | Catch an exception and map it to another exception type before rethrowing.+--+-- @since 0.2.0.0+mapExceptionTx+  :: (Exception e, Exception e')+  => (e -> Maybe e')+  -> TxM r a+  -> TxM r a+mapExceptionTx mapper action = do+  unsafeWithRunInIOTxM \run -> do+    catch (run action) \ex -> do+      case mapper ex of+        Nothing -> throwIO ex+        Just ex' -> throwIO ex'++data TxException = TxException+  { errorType :: TxErrorType+  , cause :: SomeException+  } deriving stock (Show)++instance Exception TxException++data TxErrorType =+    TxSerializationFailure+  | TxDeadlockDetected+  | TxOtherError (Maybe String) -- ^ PostgreSQL @errcode@, if applicable.+    deriving stock (Show, Eq)++shouldRetryTx :: TxException -> Bool+shouldRetryTx e =+  errorType e `elem`+    [ TxSerializationFailure+    , TxDeadlockDetected+    ]++fromSqlState :: Maybe String -> TxErrorType+fromSqlState = \case+  Just "40001" -> TxSerializationFailure+  Just "40P01" -> TxDeadlockDetected+  sqlState -> TxOtherError sqlState++unsafeMkTxException+  :: (Exception e) => (e -> Maybe String) -> e -> TxException+unsafeMkTxException f = unsafeMkTxException' (fromSqlState . f)++unsafeMkTxException'+  :: (Exception e)+  => (e -> TxErrorType)+  -> e -> TxException+unsafeMkTxException' f e =+  TxException+    { errorType = f e+    , cause = toException e+    }++-- $disclaimer+--+-- Changes to this module will not be reflected in the library's version+-- updates.

@@ -0,0 +1,35 @@+module Database.PostgreSQL.Tx.Unsafe+  ( -- * Introduction+    -- $intro++    -- ** Operations+    unsafeRunIOInTxM+  , unsafeWithRunInIOTxM++    -- ** For adaptor libraries+  , unsafeUnTxM+  , unsafeRunTxM++  , unsafeMkTxM+  , unsafeMksTxM++  , unsafeLookupTxEnvIO++  , unsafeMkTxException+  ) where++import Database.PostgreSQL.Tx.Internal++-- $intro+--+-- @postgresql-tx@ discourages performing arbitrary 'IO' within a database+-- transaction, but sometimes performing this 'IO' is necessary. This module+-- provides operations and infrastructure for performing "unsafe" 'IO' actions+-- within 'TxM' or a specific database library implementation monad. It also+-- provides utilities for use in adaptor libraries.+--+-- Clients must explicitly import this module to perform 'IO' in 'TxM' or a+-- specific database library implementation monad. All functions this module+-- provides are prefixed with @unsafe*@. These two factors serve as annotation+-- to simplify understanding exactly which parts of transactional database code+-- are performing arbitary 'IO'.