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 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 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..63141a1ca 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,19 @@ 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 -> + mask $ \restore -> do + let sqlBackend = projectBackend conn + let getter = getStmtConn sqlBackend + restore $ connBegin sqlBackend getter Nothing + a <- restore (runInIO (runReaderT r conn)) + `UE.catchAny` \e -> do + restore $ connRollback sqlBackend getter + UE.throwIO e + restore $ connCommit sqlBackend getter + pure a -- | Like 'runSqlPool', but supports specifying an isolation level. -- @@ -95,29 +113,18 @@ 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 -> + mask $ \restore -> do + let sqlBackend = projectBackend conn + let getter = getStmtConn sqlBackend + restore $ connBegin sqlBackend getter (Just i) + a <- restore (runInIO (runReaderT r conn)) + `UE.catchAny` \e -> do + restore $ connRollback sqlBackend getter + UE.throwIO e + restore $ connCommit sqlBackend getter + pure a rawAcquireSqlConn :: forall backend m 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