From 4d224cac375503db5fea9b3ec21ceca0b5ef0b4a Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 16 Mar 2021 18:17:30 -0600 Subject: [PATCH 1/5] Backport #1207 to persistent-2.10.5 --- persistent/ChangeLog.md | 5 +++ persistent/Database/Persist/Sql/Run.hs | 53 ++++++++++++++------------ 2 files changed, 34 insertions(+), 24 deletions(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 48069aaa6..fb35e3396 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent +## 2.10.5.4 + +* Backported the fix from [#1207](https://github.com/yesodweb/persistent/pull/1207) for asynchronous exceptions. + * Deprecated the `Acquire` family of functions. + ## 2.10.5.3 * Backported the fix from [#1135](https://github.com/yesodweb/persistent/pull/1135) to the 2.10 branch. diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs index bbc2b1365..c3ecc01d4 100644 --- a/persistent/Database/Persist/Sql/Run.hs +++ b/persistent/Database/Persist/Sql/Run.hs @@ -44,6 +44,8 @@ unsafeAcquireSqlConnFromPool = do return $ fst <$> mkAcquireType (P.takeResource pool) freeConn +{-# DEPRECATED unsafeAcquireSqlConnFromPool "The Pool ~> Acquire functions are unpredictable and may result in resource leaks with asynchronous exceptions. They will be removed in 2.12. If you need them, please file an issue and we'll try to help get you sorted. See issue #1199 on GitHub for the debugging log." #-} + -- | The returned 'Acquire' gets a connection from the pool, starts a new -- transaction and gives access to the prepared connection. @@ -66,6 +68,8 @@ acquireSqlConnFromPool = do connFromPool <- unsafeAcquireSqlConnFromPool return $ connFromPool >>= acquireSqlConn +{-# DEPRECATED acquireSqlConnFromPool "The Pool ~> Acquire functions are unpredictable and may result in resource leaks with asynchronous exceptions. They will be removed in 2.12. If you need them, please file an issue and we'll try to help get you sorted. See issue #1199 on GitHub for the debugging log." #-} +-- -- | Like 'acquireSqlConnFromPool', but lets you specify an explicit isolation -- level. -- @@ -77,6 +81,8 @@ acquireSqlConnFromPoolWithIsolation isolation = do connFromPool <- unsafeAcquireSqlConnFromPool return $ connFromPool >>= acquireSqlConnWithIsolation isolation +{-# DEPRECATED acquireSqlConnFromPoolWithIsolation "The Pool ~> Acquire functions are unpredictable and may result in resource leaks with asynchronous exceptions. They will be removed in 2.12. If you need them, please file an issue and we'll try to help get you sorted. See issue #1199 on GitHub for the debugging log." #-} + -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool. -- @@ -86,7 +92,18 @@ acquireSqlConnFromPoolWithIsolation isolation = do runSqlPool :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> m a -runSqlPool r pconn = with (acquireSqlConnFromPool pconn) $ runReaderT r +runSqlPool r pconn = + withRunInIO $ \runInIO -> + withResource pconn $ \conn -> do + let sqlBackend = projectBackend conn + let getter = getStmtConn sqlBackend + connBegin sqlBackend getter Nothing + a <- runInIO (runReaderT r conn) + `UE.catchAny` \e -> do + connRollback sqlBackend getter + UE.throwIO e + connCommit sqlBackend getter + pure a -- | Like 'runSqlPool', but supports specifying an isolation level. -- @@ -95,29 +112,17 @@ runSqlPoolWithIsolation :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a runSqlPoolWithIsolation r pconn i = - with (acquireSqlConnFromPoolWithIsolation i pconn) $ runReaderT r - --- | Like 'withResource', but times out the operation if resource --- allocation does not complete within the given timeout period. --- --- @since 2.0.0 -withResourceTimeout - :: forall a m b. (MonadUnliftIO m) - => Int -- ^ Timeout period in microseconds - -> Pool a - -> (a -> m b) - -> m (Maybe b) -{-# SPECIALIZE withResourceTimeout :: Int -> Pool a -> (a -> IO b) -> IO (Maybe b) #-} -withResourceTimeout ms pool act = withRunInIO $ \runInIO -> mask $ \restore -> do - mres <- timeout ms $ takeResource pool - case mres of - Nothing -> runInIO $ return (Nothing :: Maybe b) - Just (resource, local) -> do - ret <- restore (runInIO (liftM Just $ act resource)) `onException` - destroyResource pool local resource - putResource local resource - return ret -{-# INLINABLE withResourceTimeout #-} + withRunInIO $ \runInIO -> + withResource pconn $ \conn -> do + let sqlBackend = projectBackend conn + let getter = getStmtConn sqlBackend + connBegin sqlBackend getter (Just i) + a <- runInIO (runReaderT r conn) + `UE.catchAny` \e -> do + connRollback sqlBackend getter + UE.throwIO e + connCommit sqlBackend getter + pure a rawAcquireSqlConn :: forall backend m From de6bfa50624e2a644ecb8ad8a0cc2da7de500bc8 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 16 Mar 2021 18:18:20 -0600 Subject: [PATCH 2/5] bump persistent version --- persistent/persistent.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 76e38a81d..5f6b9bf5d 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.10.5.3 +version: 2.10.5.4 license: MIT license-file: LICENSE author: Michael Snoyman From 1e8ae69860aeafc4913c568e875933ee1c17ba71 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 16 Mar 2021 18:26:26 -0600 Subject: [PATCH 3/5] sigh --- .github/workflows/haskell.yml | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index c616d778b..df9e14926 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -10,6 +10,19 @@ on: jobs: build: services: + postgres: + image: postgres:12-alpine + env: + POSTGRES_USER: perstest + POSTGRES_PASSWORD: perstest + POSTGRES_DB: persistent + ports: + - 5432:5432 + options: >- + --health-cmd pg_isready + --health-interval 10s + --health-timeout 5s + --health-retries 5 # mysql-service Label used to access the service container mysql-service: # Docker Hub image (also with version) @@ -33,24 +46,24 @@ jobs: strategy: matrix: cabal: ["3.2"] - ghc: ["8.6.5", "8.8.3", "8.10.1"] + ghc: + - "8.2.2" + - "8.4.4" + - "8.6.5" + - "8.8.4" + - "8.10.1" + env: CONFIG: "--enable-tests" steps: - uses: actions/checkout@v2 - - uses: actions/setup-haskell@v1.1.2 + - uses: actions/setup-haskell@v1.1.4 id: setup-haskell-cabal with: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} - name: Check MySQL connection run: mysql -utest -ptest -h127.0.0.1 --port=33306 test -e "SELECT 1;" - - uses: harmon758/postgresql-action@v1 - with: - postgresql version: '12' # See https://hub.docker.com/_/postgres for available versions - postgresql user: perstest - postgresql password: perstest - postgresql db: persistent - name: Start MongoDB uses: supercharge/mongodb-github-action@1.3.0 - name: Start Redis From b5ffe48ff4dc14213bcd48bee47329336b0dc905 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 17 Mar 2021 08:45:32 -0600 Subject: [PATCH 4/5] fix ci --- .../persistent-postgresql.cabal | 1 + persistent-postgresql/test/PgInit.hs | 41 +++++++++++++------ 2 files changed, 30 insertions(+), 12 deletions(-) diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 87ea7e1c0..43a2af200 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -72,6 +72,7 @@ test-suite test , time , transformers , unliftio-core + , unliftio , unordered-containers , vector default-language: Haskell2010 diff --git a/persistent-postgresql/test/PgInit.hs b/persistent-postgresql/test/PgInit.hs index 86cff2e0b..88871f805 100644 --- a/persistent-postgresql/test/PgInit.hs +++ b/persistent-postgresql/test/PgInit.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module PgInit ( @@ -38,7 +38,6 @@ import Init ) -- re-exports -import Control.Exception (SomeException) import Control.Monad (void, replicateM, liftM, when, forM_) import Control.Monad.Trans.Reader import Data.Aeson (Value(..)) @@ -55,6 +54,7 @@ import Test.QuickCheck import Control.Monad (unless, (>=>)) import Control.Monad.IO.Class import Control.Monad.IO.Unlift (MonadUnliftIO) +import UnliftIO.Exception import Control.Monad.Logger import Control.Monad.Trans.Resource (ResourceT, runResourceT) import qualified Data.ByteString as BS @@ -86,16 +86,33 @@ persistSettings = sqlSettings { mpsGeneric = True } runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () runConn f = do - travis <- liftIO isTravis - let debugPrint = not travis && _debugOn - let printDebug = if debugPrint then print . fromLogStr else void . return - flip runLoggingT (\_ _ _ s -> printDebug s) $ do - _ <- if travis - then withPostgresqlPool "host=localhost port=5432 user=postgres dbname=persistent" 1 $ runSqlPool f - else do - host <- fromMaybe "localhost" <$> liftIO dockerPg - withPostgresqlPool ("host=" <> host <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f - return () + travis <- liftIO isTravis + let debugPrint = not travis && _debugOn + let printDebug = if debugPrint then print . fromLogStr else void . return + runLog a = runLoggingT a (\_ _ _ s -> printDebug s) + let go = + if travis + then + withPostgresqlPool "host=localhost port=5432 user=postgres dbname=persistent" 1 $ runSqlPool f + else do + host <- fromMaybe "localhost" <$> liftIO dockerPg + withPostgresqlPool ("host=" <> host <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f + -- horrifying hack :( postgresql is having weird connection failures in + -- CI, for no reason that i can determine. see this PR for notes: + -- https://github.com/yesodweb/persistent/pull/1197 + eres <- try $ runLog go + void $ case eres of + Left (err :: SomeException) -> do + eres' <- try $ runLog go + case eres' of + Left (err' :: SomeException) -> + if show err == show err' + then throwIO err + else throwIO err' + Right a -> + pure a + Right a -> + pure a db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion db actions = do From 864e36fbecf2aad0793c46bde6a807413db865e5 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 17 Mar 2021 14:57:24 -0600 Subject: [PATCH 5/5] restore masking --- persistent/Database/Persist/Sql/Run.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs index c3ecc01d4..63141a1ca 100644 --- a/persistent/Database/Persist/Sql/Run.hs +++ b/persistent/Database/Persist/Sql/Run.hs @@ -94,15 +94,16 @@ runSqlPool => ReaderT backend m a -> Pool backend -> m a runSqlPool r pconn = withRunInIO $ \runInIO -> - withResource pconn $ \conn -> do + withResource pconn $ \conn -> + mask $ \restore -> do let sqlBackend = projectBackend conn let getter = getStmtConn sqlBackend - connBegin sqlBackend getter Nothing - a <- runInIO (runReaderT r conn) + restore $ connBegin sqlBackend getter Nothing + a <- restore (runInIO (runReaderT r conn)) `UE.catchAny` \e -> do - connRollback sqlBackend getter + restore $ connRollback sqlBackend getter UE.throwIO e - connCommit sqlBackend getter + restore $ connCommit sqlBackend getter pure a -- | Like 'runSqlPool', but supports specifying an isolation level. @@ -113,15 +114,16 @@ runSqlPoolWithIsolation => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a runSqlPoolWithIsolation r pconn i = withRunInIO $ \runInIO -> - withResource pconn $ \conn -> do + withResource pconn $ \conn -> + mask $ \restore -> do let sqlBackend = projectBackend conn let getter = getStmtConn sqlBackend - connBegin sqlBackend getter (Just i) - a <- runInIO (runReaderT r conn) + restore $ connBegin sqlBackend getter (Just i) + a <- restore (runInIO (runReaderT r conn)) `UE.catchAny` \e -> do - connRollback sqlBackend getter + restore $ connRollback sqlBackend getter UE.throwIO e - connCommit sqlBackend getter + restore $ connCommit sqlBackend getter pure a rawAcquireSqlConn