Better implementation of defaultGetDBRunner
This commit is contained in:
parent
aef99b44d8
commit
6ef507e54f
@ -25,8 +25,7 @@ import Control.Monad.Trans.Reader (runReaderT)
|
|||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
import Data.Conduit
|
import Data.Conduit
|
||||||
import Blaze.ByteString.Builder (Builder)
|
import Blaze.ByteString.Builder (Builder)
|
||||||
import Data.IORef.Lifted
|
import Data.Pool
|
||||||
import Data.Conduit.Pool
|
|
||||||
import Control.Monad.Trans.Resource
|
import Control.Monad.Trans.Resource
|
||||||
import Control.Exception (throwIO)
|
import Control.Exception (throwIO)
|
||||||
import Yesod.Core.Types (HandlerContents (HCError))
|
import Yesod.Core.Types (HandlerContents (HCError))
|
||||||
@ -82,24 +81,23 @@ defaultGetDBRunner :: YesodPersistBackend site ~ SqlPersistT
|
|||||||
=> (site -> Pool SQL.Connection)
|
=> (site -> Pool SQL.Connection)
|
||||||
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
|
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
|
||||||
defaultGetDBRunner getPool = do
|
defaultGetDBRunner getPool = do
|
||||||
ididSucceed <- newIORef False
|
|
||||||
|
|
||||||
pool <- fmap getPool getYesod
|
pool <- fmap getPool getYesod
|
||||||
managedConn <- takeResource pool
|
let withPrep conn f = f conn (SQL.connPrepare conn)
|
||||||
let conn = mrValue managedConn
|
(relKey, (conn, local)) <- allocate
|
||||||
|
(do
|
||||||
|
(conn, local) <- takeResource pool
|
||||||
|
withPrep conn SQL.connBegin
|
||||||
|
return (conn, local)
|
||||||
|
)
|
||||||
|
(\(conn, local) -> do
|
||||||
|
withPrep conn SQL.connRollback
|
||||||
|
destroyResource pool local conn)
|
||||||
|
|
||||||
let withPrep f = f conn (SQL.connPrepare conn)
|
let cleanup = liftIO $ do
|
||||||
(finishTransaction, ()) <- allocate (withPrep SQL.connBegin) $ \() -> do
|
withPrep conn SQL.connCommit
|
||||||
didSucceed <- readIORef ididSucceed
|
putResource local conn
|
||||||
withPrep $ if didSucceed
|
_ <- unprotect relKey
|
||||||
then SQL.connCommit
|
return ()
|
||||||
else SQL.connRollback
|
|
||||||
|
|
||||||
let cleanup = do
|
|
||||||
writeIORef ididSucceed True
|
|
||||||
release finishTransaction
|
|
||||||
mrReuse managedConn True
|
|
||||||
mrRelease managedConn
|
|
||||||
|
|
||||||
return (DBRunner $ \x -> runReaderT (unSqlPersistT x) conn, cleanup)
|
return (DBRunner $ \x -> runReaderT (unSqlPersistT x) conn, cleanup)
|
||||||
|
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-persistent
|
name: yesod-persistent
|
||||||
version: 1.2.2.1
|
version: 1.2.2.2
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman <michael@snoyman.com>
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
@ -20,9 +20,8 @@ library
|
|||||||
, transformers >= 0.2.2 && < 0.4
|
, transformers >= 0.2.2 && < 0.4
|
||||||
, blaze-builder
|
, blaze-builder
|
||||||
, conduit
|
, conduit
|
||||||
, lifted-base
|
, resourcet >= 0.4.5
|
||||||
, pool-conduit
|
, resource-pool
|
||||||
, resourcet
|
|
||||||
exposed-modules: Yesod.Persist
|
exposed-modules: Yesod.Persist
|
||||||
Yesod.Persist.Core
|
Yesod.Persist.Core
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user