diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Change log +## 0.2.0.0 + +* Updated for postgresql-tx-0.2.0.0. +* Updated `SquealM` encoding. +* Added `SquealTxM` and `SquealTxM'`. +* Updated `transactionallyRetry` to allow for retrying on a predicate. +* Added `transactionallySerializable`. +* Moved internals to an `Internal` module. + ## 0.1.0.0 -Initial release +* Initial release diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,6 +1,6 @@ name: postgresql-tx-squeal -version: 0.1.0.0 -github: "simspace/postgresql-tx/squeal" +version: 0.2.0.0 +github: "simspace/postgresql-tx" license: BSD3 license-file: LICENSE.md author: "Cary Robbins" @@ -23,9 +23,10 @@ - bytestring >= 0.10.10.0 && < 0.11 - generics-sop >= 0.5.1.0 && < 0.6 - postgresql-libpq >= 0.9.4.2 && < 0.10 -- postgresql-tx >= 0.1.0.0 && < 0.2 +- postgresql-tx >= 0.2.0.0 && < 0.3 - records-sop >= 0.1.0.3 && < 0.2 -- squeal-postgresql >= 0.6.0.2 && < 0.7 +- squeal-postgresql >= 0.7.0.1 && < 0.8 +- unliftio >= 0.2.13 && < 0.3 library: source-dirs: src diff --git a/postgresql-tx-squeal.cabal b/postgresql-tx-squeal.cabal --- a/postgresql-tx-squeal.cabal +++ b/postgresql-tx-squeal.cabal @@ -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: ec2093cdd28764a2714fde9b8bb6779e505a1ebb631618e8362b78c63e60d8ab +-- hash: e701f125cf44879463dd9939bb3949bfcb0630c866cf1314ee8a603d80a588e5 name: postgresql-tx-squeal -version: 0.1.0.0 +version: 0.2.0.0 synopsis: postgresql-tx interfacing for use with squeal-postgresql. description: Please see the README on GitHub at category: Database @@ -27,11 +27,11 @@ source-repository head type: git location: https://github.com/simspace/postgresql-tx - subdir: squeal library exposed-modules: Database.PostgreSQL.Tx.Squeal + Database.PostgreSQL.Tx.Squeal.Internal Database.PostgreSQL.Tx.Squeal.Internal.Reexport other-modules: Paths_postgresql_tx_squeal @@ -43,7 +43,8 @@ , bytestring >=0.10.10.0 && <0.11 , generics-sop >=0.5.1.0 && <0.6 , postgresql-libpq >=0.9.4.2 && <0.10 - , postgresql-tx >=0.1.0.0 && <0.2 + , postgresql-tx >=0.2.0.0 && <0.3 , records-sop >=0.1.0.3 && <0.2 - , squeal-postgresql >=0.6.0.2 && <0.7 + , squeal-postgresql >=0.7.0.1 && <0.8 + , unliftio >=0.2.13 && <0.3 default-language: Haskell2010 diff --git a/src/Database/PostgreSQL/Tx/Squeal.hs b/src/Database/PostgreSQL/Tx/Squeal.hs --- a/src/Database/PostgreSQL/Tx/Squeal.hs +++ b/src/Database/PostgreSQL/Tx/Squeal.hs @@ -1,135 +1,191 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.PostgreSQL.Tx.Squeal - ( module Database.PostgreSQL.Tx.Squeal + ( SquealEnv + , SquealM + , SquealTxM'(SquealTxM, fromSquealTxM) + , SquealTxM + , SquealConnection + , mkSquealConnection + , module Database.PostgreSQL.Tx.Squeal , module Database.PostgreSQL.Tx.Squeal.Internal.Reexport ) where +import Control.Exception (Exception) import Data.ByteString (ByteString) -import Database.PostgreSQL.Tx (Tx(TxEnv, tx), UnsafeTx(unsafeIOTx), TxM, unsafeRunTxM) +import Database.PostgreSQL.Tx (TxM, shouldRetryTx) +import Database.PostgreSQL.Tx.Squeal.Internal import Database.PostgreSQL.Tx.Squeal.Internal.Reexport import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Generics.SOP as SOP import qualified Generics.SOP.Record as SOP import qualified Squeal.PostgreSQL as Squeal -type SquealM db0 db1 = PQ db0 db1 TxM - -unsafeSquealIOTx :: PQ db0 db1 IO a -> SquealM db0 db1 a -unsafeSquealIOTx = unsafeIOTx - -unsafeSquealIOTx1 - :: (x1 -> PQ db0 db1 IO a) - -> x1 -> SquealM db0 db1 a -unsafeSquealIOTx1 f x1 = unsafeSquealIOTx $ f x1 - -unsafeSquealIOTx2 - :: (x1 -> x2 -> PQ db0 db1 IO a) - -> x1 -> x2 -> SquealM db0 db1 a -unsafeSquealIOTx2 f x1 x2 = unsafeSquealIOTx $ f x1 x2 - -unsafeSquealIOTx3 - :: (x1 -> x2 -> x3 -> PQ db0 db1 IO a) - -> x1 -> x2 -> x3 -> SquealM db0 db1 a -unsafeSquealIOTx3 f x1 x2 x3 = unsafeSquealIOTx $ f x1 x2 x3 - -getRow :: LibPQ.Row -> Result y -> SquealM db db y -getRow = unsafeSquealIOTx2 Squeal.getRow +-- | Analogue of 'Squeal.getRow'. +-- +-- @since 0.1.0.0 +getRow :: LibPQ.Row -> Result y -> SquealTxM db y +getRow = unsafeSquealIOTxM2 Squeal.getRow -firstRow :: Result y -> SquealM db db (Maybe y) -firstRow = unsafeSquealIOTx1 Squeal.firstRow +-- | Analogue of 'Squeal.firstRow'. +-- +-- @since 0.1.0.0 +firstRow :: Result y -> SquealTxM db (Maybe y) +firstRow = unsafeSquealIOTxM1 Squeal.firstRow -getRows :: Result y -> SquealM db db [y] -getRows = unsafeSquealIOTx1 Squeal.getRows +-- | Analogue of 'Squeal.getRows'. +-- +-- @since 0.1.0.0 +getRows :: Result y -> SquealTxM db [y] +getRows = unsafeSquealIOTxM1 Squeal.getRows -nextRow :: LibPQ.Row -> Result y -> LibPQ.Row -> SquealM db db (Maybe (LibPQ.Row, y)) -nextRow = unsafeSquealIOTx3 Squeal.nextRow +-- | Analogue of 'Squeal.nextRow'. +-- +-- @since 0.1.0.0 +nextRow :: LibPQ.Row -> Result y -> LibPQ.Row -> SquealTxM db (Maybe (LibPQ.Row, y)) +nextRow = unsafeSquealIOTxM3 Squeal.nextRow -ntuples :: Result y -> SquealM db db LibPQ.Row -ntuples = unsafeSquealIOTx1 Squeal.ntuples +-- | Analogue of 'Squeal.ntuples'. +-- +-- @since 0.1.0.0 +ntuples :: Result y -> SquealTxM db LibPQ.Row +ntuples = unsafeSquealIOTxM1 Squeal.ntuples -nfields :: Result y -> SquealM db db LibPQ.Column -nfields = unsafeSquealIOTx1 Squeal.nfields +-- | Analogue of 'Squeal.nfields'. +-- +-- @since 0.1.0.0 +nfields :: Result y -> SquealTxM db LibPQ.Column +nfields = unsafeSquealIOTxM1 Squeal.nfields -resultStatus :: Result y -> SquealM db db ExecStatus -resultStatus = unsafeSquealIOTx1 Squeal.resultStatus +-- | Analogue of 'Squeal.resultStatus'. +-- +-- @since 0.1.0.0 +resultStatus :: Result y -> SquealTxM db ExecStatus +resultStatus = unsafeSquealIOTxM1 Squeal.resultStatus -okResult :: K LibPQ.Result row -> SquealM db db () -okResult = unsafeSquealIOTx1 Squeal.okResult +-- | Analogue of 'Squeal.okResult'. +-- +-- @since 0.2.0.0 +okResult :: Result y -> SquealTxM db () +okResult = unsafeSquealIOTxM1 Squeal.okResult -resultErrorMessage :: Result y -> SquealM db db (Maybe ByteString) -resultErrorMessage = unsafeSquealIOTx1 Squeal.resultErrorMessage +-- | Analogue of 'Squeal.resultErrorMessage'. +-- +-- @since 0.1.0.0 +resultErrorMessage :: Result y -> SquealTxM db (Maybe ByteString) +resultErrorMessage = unsafeSquealIOTxM1 Squeal.resultErrorMessage -resultErrorCode :: Result y -> SquealM db db (Maybe ByteString) -resultErrorCode = unsafeSquealIOTx1 Squeal.resultErrorCode +-- | Analogue of 'Squeal.resultErrorCode'. +-- +-- @since 0.1.0.0 +resultErrorCode :: Result y -> SquealTxM db (Maybe ByteString) +resultErrorCode = unsafeSquealIOTxM1 Squeal.resultErrorCode -executeParams :: Statement db x y -> x -> SquealM db db (Result y) -executeParams = unsafeSquealIOTx2 Squeal.executeParams +-- | Analogue of 'Squeal.executeParams'. +-- +-- @since 0.1.0.0 +executeParams :: Statement db x y -> x -> SquealTxM db (Result y) +executeParams = unsafeSquealIOTxM2 Squeal.executeParams -executeParams_ :: Statement db x () -> x -> SquealM db db () -executeParams_ = unsafeSquealIOTx2 Squeal.executeParams_ +-- | Analogue of 'Squeal.executeParams_'. +-- +-- @since 0.1.0.0 +executeParams_ :: Statement db x () -> x -> SquealTxM db () +executeParams_ = unsafeSquealIOTxM2 Squeal.executeParams_ -execute :: Statement db () y -> SquealM db db (Result y) -execute = unsafeSquealIOTx1 Squeal.execute +-- | Analogue of 'Squeal.execute'. +-- +-- @since 0.1.0.0 +execute :: Statement db () y -> SquealTxM db (Result y) +execute = unsafeSquealIOTxM1 Squeal.execute -execute_ :: Statement db () () -> SquealM db db () -execute_ = unsafeSquealIOTx1 Squeal.execute_ +-- | Analogue of 'Squeal.execute_'. +-- +-- @since 0.1.0.0 +execute_ :: Statement db () () -> SquealTxM db () +execute_ = unsafeSquealIOTxM1 Squeal.execute_ +-- | Analogue of 'Squeal.executePrepared'. +-- +-- @since 0.1.0.0 executePrepared :: (Traversable list) - => Statement db x y -> list x -> SquealM db db (list (Result y)) -executePrepared = unsafeSquealIOTx2 Squeal.executePrepared + => Statement db x y -> list x -> SquealTxM db (list (Result y)) +executePrepared = unsafeSquealIOTxM2 Squeal.executePrepared +-- | Analogue of 'Squeal.executePrepared_'. +-- +-- @since 0.1.0.0 executePrepared_ :: (Foldable list) - => Statement db x () -> list x -> SquealM db db () -executePrepared_ = unsafeSquealIOTx2 Squeal.executePrepared_ + => Statement db x () -> list x -> SquealTxM db () +executePrepared_ = unsafeSquealIOTxM2 Squeal.executePrepared_ +-- | Analogue of 'Squeal.manipulateParams'. +-- +-- @since 0.1.0.0 manipulateParams :: ( GenericParams db params x xs , Squeal.GenericRow row y ys ) => Manipulation '[] db params row -> x - -> SquealM db db (Result y) -manipulateParams = unsafeSquealIOTx2 Squeal.manipulateParams + -> SquealTxM db (Result y) +manipulateParams = unsafeSquealIOTxM2 Squeal.manipulateParams +-- | Analogue of 'Squeal.manipulateParams_'. +-- +-- @since 0.1.0.0 manipulateParams_ :: (GenericParams db params x xs) - => Manipulation '[] db params '[] -> x -> SquealM db db () -manipulateParams_ = unsafeSquealIOTx2 Squeal.manipulateParams_ + => Manipulation '[] db params '[] -> x -> SquealTxM db () +manipulateParams_ = unsafeSquealIOTxM2 Squeal.manipulateParams_ +-- | Analogue of 'Squeal.manipulate'. +-- +-- @since 0.1.0.0 manipulate :: (Squeal.GenericRow row y ys) - => Manipulation '[] db '[] row -> SquealM db db (Result y) -manipulate = unsafeSquealIOTx1 Squeal.manipulate + => Manipulation '[] db '[] row -> SquealTxM db (Result y) +manipulate = unsafeSquealIOTxM1 Squeal.manipulate +-- | Analogue of 'Squeal.manipulate_'. +-- +-- @since 0.1.0.0 manipulate_ - :: Manipulation '[] db '[] '[] -> SquealM db db () -manipulate_ = unsafeSquealIOTx1 Squeal.manipulate_ + :: Manipulation '[] db '[] '[] -> SquealTxM db () +manipulate_ = unsafeSquealIOTxM1 Squeal.manipulate_ +-- | Analogue of 'Squeal.runQueryParams'. +-- +-- @since 0.1.0.0 runQueryParams :: ( GenericParams db params x xs , SOP.IsRecord y ys , SOP.AllZip Squeal.FromField row ys ) - => Squeal.Query '[] '[] db params row -> x -> SquealM db db (Result y) -runQueryParams = unsafeSquealIOTx2 Squeal.runQueryParams + => Squeal.Query '[] '[] db params row -> x -> SquealTxM db (Result y) +runQueryParams = unsafeSquealIOTxM2 Squeal.runQueryParams +-- | Analogue of 'Squeal.runQuery'. +-- +-- @since 0.1.0.0 runQuery :: ( SOP.IsRecord y ys , SOP.AllZip Squeal.FromField row ys ) - => Squeal.Query '[] '[] db '[] row -> SquealM db db (Result y) -runQuery = unsafeSquealIOTx1 Squeal.runQuery + => Squeal.Query '[] '[] db '[] row -> SquealTxM db (Result y) +runQuery = unsafeSquealIOTxM1 Squeal.runQuery +-- | Analogue of 'Squeal.traversePrepared'. +-- +-- @since 0.1.0.0 traversePrepared :: ( GenericParams db params x xs , Traversable list @@ -138,9 +194,12 @@ ) => Manipulation '[] db params row -> list x - -> SquealM db db (list (Result y)) -traversePrepared = unsafeSquealIOTx2 Squeal.traversePrepared + -> SquealTxM db (list (Result y)) +traversePrepared = unsafeSquealIOTxM2 Squeal.traversePrepared +-- | Analogue of 'Squeal.forPrepared'. +-- +-- @since 0.1.0.0 forPrepared :: ( GenericParams db params x xs , Traversable list @@ -149,55 +208,81 @@ ) => list x -> Manipulation '[] db params row - -> SquealM db db (list (Result y)) -forPrepared = unsafeSquealIOTx2 Squeal.forPrepared + -> SquealTxM db (list (Result y)) +forPrepared = unsafeSquealIOTxM2 Squeal.forPrepared +-- | Analogue of 'Squeal.traversePrepared_'. +-- +-- @since 0.1.0.0 traversePrepared_ :: ( GenericParams db params x xs , Foldable list ) => Manipulation '[] db params '[] -> list x - -> SquealM db db () -traversePrepared_ = unsafeSquealIOTx2 Squeal.traversePrepared_ + -> SquealTxM db () +traversePrepared_ = unsafeSquealIOTxM2 Squeal.traversePrepared_ +-- | Analogue of 'Squeal.forPrepared_'. +-- +-- @since 0.1.0.0 forPrepared_ :: ( GenericParams db params x xs , Foldable list ) => list x -> Manipulation '[] db params '[] - -> SquealM db db () -forPrepared_ = unsafeSquealIOTx2 Squeal.forPrepared_ + -> SquealTxM db () +forPrepared_ = unsafeSquealIOTxM2 Squeal.forPrepared_ -transactionally :: TransactionMode -> Connection -> TxM a -> IO a +-- | Analogue of 'Squeal.transactionally'. +-- +-- @since 0.1.0.0 +transactionally :: (SquealEnv r) => TransactionMode -> r -> TxM r a -> IO a transactionally m = unsafeRunSquealTransaction (Squeal.transactionally m) -transactionally_ :: Connection -> TxM a -> IO a +-- | Analogue of 'Squeal.transactionally_'. +-- +-- @since 0.1.0.0 +transactionally_ :: (SquealEnv r) => r -> TxM r a -> IO a transactionally_ = unsafeRunSquealTransaction Squeal.transactionally_ -transactionallyRetry :: TransactionMode -> Connection -> TxM a -> IO a -transactionallyRetry m = unsafeRunSquealTransaction (Squeal.transactionallyRetry m) +-- | Specialization of 'transactionallyRetry' which uses 'Serializable' +-- and 'shouldRetryTx' to automatically retry the transaction on +-- @serialization_failure@ or @deadlock_detected@. +-- +-- Note that any 'IO' that occurs inside the 'TxM' may be executed multiple times. +-- +-- @since 0.2.0.0 +transactionallySerializable :: (SquealEnv r) => r -> TxM r a -> IO a +transactionallySerializable = + transactionallyRetry mode shouldRetryTx + where + mode = + TransactionMode + Serializable + ReadWrite + NotDeferrable -ephemerally :: TransactionMode -> Connection -> TxM a -> IO a +-- | Analogue of 'Squeal.transactionallyRetry'. +-- +-- Note that any 'IO' that occurs inside the 'TxM' may be executed multiple times. +-- +-- @since 0.2.0.0 +transactionallyRetry + :: (SquealEnv r, Exception e) + => TransactionMode -> (e -> Bool) -> r -> TxM r a -> IO a +transactionallyRetry m shouldRetry = + unsafeRunSquealTransaction (transactionallyRetry' m shouldRetry) + +-- | Analogue of 'Squeal.ephemerally'. +-- +-- @since 0.1.0.0 +ephemerally :: (SquealEnv r) => TransactionMode -> r -> TxM r a -> IO a ephemerally m = unsafeRunSquealTransaction (Squeal.ephemerally m) -ephemerally_ :: Connection -> TxM a -> IO a +-- | Analogue of 'Squeal.ephemerally_'. +-- +-- @since 0.1.0.0 +ephemerally_ :: (SquealEnv r) => r -> TxM r a -> IO a ephemerally_ = unsafeRunSquealTransaction Squeal.ephemerally_ - -unsafeRunSquealTransaction - :: (PQ db0 db1 IO a -> PQ db0 db1 IO a) - -> Connection - -> TxM a - -> IO a -unsafeRunSquealTransaction f conn x = - flip Squeal.evalPQ (Squeal.K conn) - $ f - $ PQ \_ -> Squeal.K <$> unsafeRunTxM x - -instance Tx (SquealM db0 db1) where - type TxEnv (SquealM db0 db1) = Connection - tx conn x = evalPQ x (Squeal.K conn) - -instance (UnsafeTx io t) => UnsafeTx (PQ db0 db1 io) (PQ db0 db1 t) where - unsafeIOTx x = PQ \kConn -> unsafeIOTx (Squeal.unPQ x kConn) diff --git a/src/Database/PostgreSQL/Tx/Squeal/Internal.hs b/src/Database/PostgreSQL/Tx/Squeal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Tx/Squeal/Internal.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +module Database.PostgreSQL.Tx.Squeal.Internal + ( -- * Disclaimer + -- $disclaimer + + -- ** Internals + module Database.PostgreSQL.Tx.Squeal.Internal + ) where + +import Control.Exception (Exception(fromException)) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.Kind (Constraint) +import Database.PostgreSQL.Tx (TxEnv, TxException, TxM, askTxEnv, mapExceptionTx) +import Database.PostgreSQL.Tx.Squeal.Internal.Reexport +import Database.PostgreSQL.Tx.Unsafe (unsafeLookupTxEnvIO, unsafeMkTxException, unsafeRunIOInTxM, unsafeRunTxM) +import GHC.TypeLits (ErrorMessage(Text), TypeError) +import UnliftIO (MonadUnliftIO) +import qualified Data.ByteString.Char8 as Char8 +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Squeal.PostgreSQL as Squeal +import qualified UnliftIO + +-- | Runtime environment needed to run @squeal-postgresql@ via @postgresql-tx@. +-- +-- @since 0.2.0.0 +type SquealEnv r = + (TxEnv SquealConnection r) :: Constraint + +-- | Monad type alias for running @squeal-postgresql@ via @postgresql-tx@. +-- +-- @since 0.2.0.0 +type SquealM a = forall r. (SquealEnv r) => TxM r a + +-- | Alias for 'SquealTxM'' but has the 'SquealEnv' constraint applied to @r@. +-- +-- @since 0.2.0.0 +type SquealTxM (db :: SchemasType) a = + forall r. (SquealEnv r) => SquealTxM' db r a + +-- | A newtype wrapper around 'TxM' which includes the @squeal@ 'SchemasType' +-- parameter @db@. This is used only as type information. +-- You can easily convert 'TxM' to and from 'SquealTxM'' by using the +-- 'SquealTxM'' constructor and 'fromSquealTxM' function, respectively. +-- +-- In practice, you will likely prefer to use the 'SquealTxM' type alias +-- as it includes the 'SquealEnv' constraint on @r@. +-- +-- @since 0.2.0.0 +newtype SquealTxM' (db :: SchemasType) r a = + SquealTxM + { -- | Convert a 'SquealTxM'' to a 'TxM'. + -- + -- @since 0.2.0.0 + fromSquealTxM :: TxM r a + } + deriving newtype (Functor, Applicative, Monad) + +-- | The 'SquealTxM'' monad discourages performing arbitrary 'IO' within a +-- transaction, so this instance generates a type error when client code tries +-- to call 'liftIO'. +-- +-- Note that we specialize this instance for 'SquealTxM'' rather than derive it +-- via newtype so we can provide a better error message. +-- +-- @since 0.2.0.0 +instance + ( TypeError + ('Text "MonadIO is banned in SquealTxM'; use 'SquealTxM . unsafeRunIOInTxM' if you are sure this is safe IO") + ) => MonadIO (SquealTxM' db r) + where + liftIO = undefined + +-- | Used in the 'SquealEnv' to specify the 'LibPQ.Connection' to use. +-- Should produce the same 'LibPQ.Connection' if called multiple times +-- in the same transaction. Usually you will want to use 'mkSquealConnection' +-- to get one. +-- +-- @since 0.2.0.0 +newtype SquealConnection = + UnsafeSquealConnection + { unsafeGetLibPQConnection :: IO LibPQ.Connection + } + +-- | Construct a 'SquealConnection' from a 'LibPQ.Connection'. +-- +-- @since 0.2.0.0 +mkSquealConnection :: LibPQ.Connection -> SquealConnection +mkSquealConnection conn = UnsafeSquealConnection (pure conn) + +fromSquealException :: SquealException -> TxException +fromSquealException = + unsafeMkTxException \case + SQLException SQLState { sqlStateCode } -> Just $ Char8.unpack sqlStateCode + _ -> Nothing + +unsafeSquealIOTxM + :: PQ db db IO a + -> SquealTxM db a +unsafeSquealIOTxM (PQ f) = SquealTxM $ mapExceptionTx (Just . fromSquealException) do + UnsafeSquealConnection { unsafeGetLibPQConnection } <- askTxEnv + unsafeRunIOInTxM do + conn <- unsafeGetLibPQConnection + K a <- f (K conn) + pure a + +unsafeSquealIOTxM1 + :: (x1 -> PQ db db IO a) + -> x1 -> SquealTxM db a +unsafeSquealIOTxM1 f x1 = unsafeSquealIOTxM $ f x1 + +unsafeSquealIOTxM2 + :: (x1 -> x2 -> PQ db db IO a) + -> x1 -> x2 -> SquealTxM db a +unsafeSquealIOTxM2 f x1 x2 = unsafeSquealIOTxM $ f x1 x2 + +unsafeSquealIOTxM3 + :: (x1 -> x2 -> x3 -> PQ db db IO a) + -> x1 -> x2 -> x3 -> SquealTxM db a +unsafeSquealIOTxM3 f x1 x2 x3 = unsafeSquealIOTxM $ f x1 x2 x3 + +unsafeRunSquealTransaction + :: forall r a. (SquealEnv r) + => (forall db. PQ db db IO a -> PQ db db IO a) + -> r + -> TxM r a + -> IO a +unsafeRunSquealTransaction f r x = do + UnsafeSquealConnection { unsafeGetLibPQConnection } <- unsafeLookupTxEnvIO r + conn <- unsafeGetLibPQConnection + flip evalPQ (K conn) + $ f + $ PQ \_ -> K <$> unsafeRunTxM r x + +-- | A variant of 'transactionallyRetry' which takes a predicate +-- for determining when to retry instead of only doing so on +-- @serialization_failure@. +transactionallyRetry' + :: (MonadUnliftIO m, MonadPQ db m, Exception e) + => TransactionMode + -> (e -> Bool) + -> m a + -> m a +transactionallyRetry' mode shouldRetry action = UnliftIO.mask $ \restore -> + loop . UnliftIO.try $ do + x <- restore action + Squeal.manipulate_ commit + return x + where + loop attempt = do + Squeal.manipulate_ $ begin mode + attempt >>= \case + Right a -> return a + Left e -> do + Squeal.manipulate_ rollback + if any shouldRetry (fromException e) then + loop attempt + else + UnliftIO.throwIO e + +-- $disclaimer +-- +-- Changes to this module will not be reflected in the library's version +-- updates.