hpqtypes 1.9.3.0 → 1.9.3.1
raw patch · 4 files changed
+25/−26 lines, 4 filesdep ~exceptionsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: exceptions
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- hpqtypes.cabal +3/−3
- src/Database/PostgreSQL/PQTypes/Internal/Connection.hs +3/−12
- src/Database/PostgreSQL/PQTypes/Transaction.hs +15/−11
CHANGELOG.md view
@@ -1,3 +1,7 @@+# hpqtypes-1.9.3.1 (2022-03-30)+* Fix `withTransaction` and `withSavepoint` with short-circuiting monad+ transformers such as `ExceptT`.+ # hpqtypes-1.9.3.0 (2022-02-25) * Fix support for M1 chips. * Add support for aeson >= 2.0.
hpqtypes.cabal view
@@ -1,5 +1,5 @@ name: hpqtypes-version: 1.9.3.0+version: 1.9.3.1 synopsis: Haskell bindings to libpqtypes description: Efficient and easy-to-use bindings to (slightly modified)@@ -39,7 +39,7 @@ category: Database build-type: Custom cabal-version: 1.24-tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2 extra-source-files: README.md@@ -138,7 +138,7 @@ , mtl >= 2.1 , transformers >= 0.2.2 , containers >= 0.5.0.0- , exceptions >= 0.6+ , exceptions >= 0.9 , text-show >= 2 , uuid-types >= 1.0.3
src/Database/PostgreSQL/PQTypes/Internal/Connection.hs view
@@ -151,25 +151,16 @@ poolSource cs numStripes idleTime maxResources = do pool <- createPool (connect cs) disconnect numStripes idleTime maxResources return $ ConnectionSource $ ConnectionSourceM {- withConnection = withResource' pool . (clearStats >=>)+ withConnection = doWithConnection pool . (clearStats >=>) } where-#if MIN_VERSION_exceptions(0,9,0)- withResource' pool m = fst <$> generalBracket+ doWithConnection pool m = fst <$> generalBracket (liftBase $ takeResource pool)- (\(resource, local) exitCase -> case exitCase of+ (\(resource, local) -> \case ExitCaseSuccess _ -> liftBase $ putResource local resource _ -> liftBase $ destroyResource pool local resource ) (\(resource, _) -> m resource)-#else- withResource' pool m = mask $ \restore -> do- (resource, local) <- liftBase $ takeResource pool- ret <- restore (m resource) `onException`- liftBase (destroyResource pool local resource)- liftBase $ putResource local resource- return ret-#endif clearStats conn@(Connection mv) = do liftBase . modifyMVar_ mv $ \mconn ->
src/Database/PostgreSQL/PQTypes/Transaction.hs view
@@ -37,11 +37,13 @@ -- See <http://www.postgresql.org/docs/current/static/sql-savepoint.html> {-# INLINABLE withSavepoint #-} withSavepoint :: (MonadDB m, MonadMask m) => Savepoint -> m a -> m a-withSavepoint (Savepoint savepoint) m = mask $ \restore -> do- runQuery_ $ "SAVEPOINT" <+> savepoint- res <- restore m `onException` rollbackAndReleaseSavepoint- runQuery_ sqlReleaseSavepoint- return res+withSavepoint (Savepoint savepoint) m = fst <$> generalBracket+ (runQuery_ $ "SAVEPOINT" <+> savepoint)+ (\() -> \case+ ExitCaseSuccess _ -> runQuery_ sqlReleaseSavepoint+ _ -> rollbackAndReleaseSavepoint+ )+ (\() -> m) where sqlReleaseSavepoint = "RELEASE SAVEPOINT" <+> savepoint rollbackAndReleaseSavepoint = do@@ -83,18 +85,20 @@ {-# INLINABLE withTransaction' #-} withTransaction' :: (MonadDB m, MonadMask m) => TransactionSettings -> m a -> m a-withTransaction' ts m = mask $ \restore -> (`fix` 1) $ \loop n -> do+withTransaction' ts m = (`fix` 1) $ \loop n -> do -- Optimization for squashing possible space leaks. -- It looks like GHC doesn't like 'catch' and passes -- on introducing strictness in some cases. let maybeRestart = case tsRestartPredicate ts of Just _ -> handleJust (expred n) (\_ -> loop $ n+1) Nothing -> id- maybeRestart $ do- begin' ts- res <- restore m `onException` rollback' ts- commit' ts- return res+ maybeRestart $ fst <$> generalBracket+ (begin' ts)+ (\() -> \case+ ExitCaseSuccess _ -> commit' ts+ _ -> rollback' ts+ )+ (\() -> m) where expred :: Integer -> SomeException -> Maybe () expred !n e = do