Use resourcet-pool (#1163)

* Use resourcet-pool * Bump version Co-authored-by: Matt Parsons <[email protected]>
yesodweb · Jan 6, 2021 · f82154f · f82154f
1 parent f69716d
commit f82154f
Show file tree

Hide file tree

Showing 4 changed files with 7 additions and 9 deletions.
diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
@@ -5,6 +5,7 @@
 * [#1162](https://github.com/yesodweb/persistent/pull/1162)
   * Replace `askLogFunc` with `askLoggerIO`
 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174)
+* Use `resourcet-pool` to break out some `Data.Pool` logic [#1163](https://github.com/yesodweb/persistent/pull/1163)
 
 ## 2.11.0.2
 * Fix a bug where an empty entity definition would break parsing of `EntityDef`s. [#1176](https://github.com/yesodweb/persistent/issues/1176)

diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
@@ -14,6 +14,7 @@ import Data.Acquire (Acquire, ReleaseType(..), mkAcquireType, with)
 import Data.IORef (readIORef)
 import Data.Pool (Pool, LocalPool)
 import Data.Pool as P
+import Data.Pool.Acquire (poolToAcquire)
 import qualified Data.Map as Map
 import qualified Data.Text as T
 import System.Timeout (timeout)
@@ -34,15 +35,7 @@ unsafeAcquireSqlConnFromPool
     :: forall backend m
      . (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend)
     => m (Acquire backend)
-unsafeAcquireSqlConnFromPool = do
-    pool <- MonadReader.ask
-
-    let freeConn :: (backend, LocalPool backend) -> ReleaseType -> IO ()
-        freeConn (res, localPool) relType = case relType of
-            ReleaseException -> P.destroyResource pool localPool res
-            _ -> P.putResource localPool res
-
-    return $ fst <$> mkAcquireType (P.takeResource pool) freeConn
+unsafeAcquireSqlConnFromPool = MonadReader.asks poolToAcquire
 
 
 -- | The returned 'Acquire' gets a connection from the pool, starts a new

diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
@@ -37,6 +37,7 @@ library
                    , path-pieces              >= 0.2
                    , resource-pool            >= 0.2.3
                    , resourcet                >= 1.1.10
+                   , resourcet-pool
                    , scientific
                    , silently
                    , text                     >= 1.2

diff --git a/stack.yaml b/stack.yaml
@@ -9,3 +9,6 @@ packages:
   - ./persistent-postgresql
   - ./persistent-redis
   - ./persistent-qq
+
+extra-deps:
+  - resourcet-pool-0.1.0.0