fix: remove cached-db-runner
Observed "connection disconnected" from persistent on 25.5.0 CachedDBRunner seemed suspicious.
This commit is contained in:
Gregor Kleen
parent
5786bc4032
commit
ff8270042f
@ -222,7 +222,7 @@ siteLayout' overrideHeading widget = do
|
||||
appFavouritesQuickActionsTimeout
|
||||
cK
|
||||
cK
|
||||
. observeFavouritesQuickActionsDuration . runCachedDBRunner $ do
|
||||
. observeFavouritesQuickActionsDuration . runDBRead $ do
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
|
||||
items' <- pageQuickActions NavQuickViewFavourite courseRoute
|
||||
items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
module Foundation.Yesod.Persist
|
||||
( runDB, getDBRunner
|
||||
, runDB', getDBRunner'
|
||||
, runCachedDBRunner
|
||||
, runCachedDBRunner'
|
||||
-- , runCachedDBRunner
|
||||
-- , runCachedDBRunner'
|
||||
, module Foundation.DB
|
||||
) where
|
||||
|
||||
@ -83,27 +83,27 @@ getDBRunner' lbl = do
|
||||
runDBRunner action'
|
||||
)
|
||||
|
||||
runCachedDBRunner :: ( BackendCompatible backend (YesodPersistBackend UniWorX)
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, BearerAuthSite UniWorX
|
||||
, HasCallStack
|
||||
)
|
||||
=> CachedDBRunner backend (HandlerFor UniWorX) a
|
||||
-> HandlerFor UniWorX a
|
||||
runCachedDBRunner = runCachedDBRunner' callStack
|
||||
-- runCachedDBRunner :: ( BackendCompatible backend (YesodPersistBackend UniWorX)
|
||||
-- , YesodPersistBackend UniWorX ~ SqlBackend
|
||||
-- , BearerAuthSite UniWorX
|
||||
-- , HasCallStack
|
||||
-- )
|
||||
-- => CachedDBRunner backend (HandlerFor UniWorX) a
|
||||
-- -> HandlerFor UniWorX a
|
||||
-- runCachedDBRunner = runCachedDBRunner' callStack
|
||||
|
||||
runCachedDBRunner' :: ( BackendCompatible backend (YesodPersistBackend UniWorX)
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> CallStack
|
||||
-> CachedDBRunner backend (HandlerFor UniWorX) a
|
||||
-> HandlerFor UniWorX a
|
||||
runCachedDBRunner' lbl act = do
|
||||
cleanups <- newTVarIO []
|
||||
res <- flip runCachedDBRunnerSTM act $ do
|
||||
(runner, cleanup) <- getDBRunner' lbl
|
||||
atomically . modifyTVar' cleanups $ (:) cleanup
|
||||
return $ fromDBRunner runner
|
||||
mapM_ liftHandler =<< readTVarIO cleanups
|
||||
return res
|
||||
-- runCachedDBRunner' :: ( BackendCompatible backend (YesodPersistBackend UniWorX)
|
||||
-- , YesodPersistBackend UniWorX ~ SqlBackend
|
||||
-- , BearerAuthSite UniWorX
|
||||
-- )
|
||||
-- => CallStack
|
||||
-- -> CachedDBRunner backend (HandlerFor UniWorX) a
|
||||
-- -> HandlerFor UniWorX a
|
||||
-- runCachedDBRunner' lbl act = do
|
||||
-- cleanups <- newTVarIO []
|
||||
-- res <- flip runCachedDBRunnerSTM act $ do
|
||||
-- (runner, cleanup) <- getDBRunner' lbl
|
||||
-- atomically . modifyTVar' cleanups $ (:) cleanup
|
||||
-- return $ fromDBRunner runner
|
||||
-- mapM_ liftHandler =<< readTVarIO cleanups
|
||||
-- return res
|
||||
|
||||
@ -20,10 +20,10 @@ import Database.Persist.Sql (runSqlConn)
|
||||
|
||||
import GHC.Stack (HasCallStack, CallStack, callStack)
|
||||
|
||||
import Control.Monad.Fix (MonadFix)
|
||||
import Control.Monad.Fail (MonadFail)
|
||||
-- import Control.Monad.Fix (MonadFix)
|
||||
-- import Control.Monad.Fail (MonadFail)
|
||||
|
||||
import Control.Monad.Trans.Reader (withReaderT)
|
||||
-- import Control.Monad.Trans.Reader (withReaderT)
|
||||
|
||||
|
||||
emptyOrIn :: PersistField typ
|
||||
@ -188,56 +188,56 @@ class WithRunDB backend m' m | m -> backend m' where
|
||||
instance WithRunDB backend m (ReaderT backend m) where
|
||||
useRunDB = id
|
||||
|
||||
newtype DBRunner' backend m = DBRunner' { runDBRunner' :: forall b. ReaderT backend m b -> m b }
|
||||
-- newtype DBRunner' backend m = DBRunner' { runDBRunner' :: forall b. ReaderT backend m b -> m b }
|
||||
|
||||
_DBRunner' :: Iso' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site))
|
||||
_DBRunner' = iso fromDBRunner' toDBRunner
|
||||
where
|
||||
fromDBRunner' :: forall site.
|
||||
DBRunner site
|
||||
-> DBRunner' (YesodPersistBackend site) (HandlerFor site)
|
||||
fromDBRunner' DBRunner{..} = DBRunner' runDBRunner
|
||||
-- _DBRunner' :: Iso' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site))
|
||||
-- _DBRunner' = iso fromDBRunner' toDBRunner
|
||||
-- where
|
||||
-- fromDBRunner' :: forall site.
|
||||
-- DBRunner site
|
||||
-- -> DBRunner' (YesodPersistBackend site) (HandlerFor site)
|
||||
-- fromDBRunner' DBRunner{..} = DBRunner' runDBRunner
|
||||
|
||||
toDBRunner :: forall site.
|
||||
DBRunner' (YesodPersistBackend site) (HandlerFor site)
|
||||
-> DBRunner site
|
||||
toDBRunner DBRunner'{..} = DBRunner runDBRunner'
|
||||
-- toDBRunner :: forall site.
|
||||
-- DBRunner' (YesodPersistBackend site) (HandlerFor site)
|
||||
-- -> DBRunner site
|
||||
-- toDBRunner DBRunner'{..} = DBRunner runDBRunner'
|
||||
|
||||
fromDBRunner :: BackendCompatible backend (YesodPersistBackend site) => DBRunner site -> DBRunner' backend (HandlerFor site)
|
||||
fromDBRunner DBRunner{..} = DBRunner' (runDBRunner . withReaderT projectBackend)
|
||||
-- fromDBRunner :: BackendCompatible backend (YesodPersistBackend site) => DBRunner site -> DBRunner' backend (HandlerFor site)
|
||||
-- fromDBRunner DBRunner{..} = DBRunner' (runDBRunner . withReaderT projectBackend)
|
||||
|
||||
newtype CachedDBRunner backend m a = CachedDBRunner { runCachedDBRunnerUsing :: m (DBRunner' backend m) -> m a }
|
||||
deriving (Functor, Applicative, Monad, MonadFix, MonadFail, Contravariant, MonadIO, Alternative, MonadPlus, MonadUnliftIO, MonadResource, MonadLogger, MonadThrow, MonadCatch, MonadMask) via (ReaderT (m (DBRunner' backend m)) m)
|
||||
-- newtype CachedDBRunner backend m a = CachedDBRunner { runCachedDBRunnerUsing :: m (DBRunner' backend m) -> m a }
|
||||
-- deriving (Functor, Applicative, Monad, MonadFix, MonadFail, Contravariant, MonadIO, Alternative, MonadPlus, MonadUnliftIO, MonadResource, MonadLogger, MonadThrow, MonadCatch, MonadMask) via (ReaderT (m (DBRunner' backend m)) m)
|
||||
|
||||
instance MonadTrans (CachedDBRunner backend) where
|
||||
lift act = CachedDBRunner (const act)
|
||||
-- instance MonadTrans (CachedDBRunner backend) where
|
||||
-- lift act = CachedDBRunner (const act)
|
||||
|
||||
instance MonadHandler m => MonadHandler (CachedDBRunner backend m) where
|
||||
type HandlerSite (CachedDBRunner backend m) = HandlerSite m
|
||||
type SubHandlerSite (CachedDBRunner backend m) = SubHandlerSite m
|
||||
-- instance MonadHandler m => MonadHandler (CachedDBRunner backend m) where
|
||||
-- type HandlerSite (CachedDBRunner backend m) = HandlerSite m
|
||||
-- type SubHandlerSite (CachedDBRunner backend m) = SubHandlerSite m
|
||||
|
||||
liftHandler = lift . liftHandler
|
||||
liftSubHandler = lift . liftSubHandler
|
||||
-- liftHandler = lift . liftHandler
|
||||
-- liftSubHandler = lift . liftSubHandler
|
||||
|
||||
instance Monad m => WithRunDB backend m (CachedDBRunner backend m) where
|
||||
useRunDB act = CachedDBRunner (\getRunner -> getRunner >>= \DBRunner'{..} -> runDBRunner' act)
|
||||
-- instance Monad m => WithRunDB backend m (CachedDBRunner backend m) where
|
||||
-- useRunDB act = CachedDBRunner (\getRunner -> getRunner >>= \DBRunner'{..} -> runDBRunner' act)
|
||||
|
||||
runCachedDBRunnerSTM :: MonadUnliftIO m
|
||||
=> m (DBRunner' backend m)
|
||||
-> CachedDBRunner backend m a
|
||||
-> m a
|
||||
runCachedDBRunnerSTM doAcquire act = do
|
||||
doAcquireLock <- newTMVarIO ()
|
||||
runnerTMVar <- newEmptyTMVarIO
|
||||
-- runCachedDBRunnerSTM :: MonadUnliftIO m
|
||||
-- => m (DBRunner' backend m)
|
||||
-- -> CachedDBRunner backend m a
|
||||
-- -> m a
|
||||
-- runCachedDBRunnerSTM doAcquire act = do
|
||||
-- doAcquireLock <- newTMVarIO ()
|
||||
-- runnerTMVar <- newEmptyTMVarIO
|
||||
|
||||
let getRunner = bracket (atomically $ takeTMVar doAcquireLock) (void . atomically . tryPutTMVar doAcquireLock) . const $ do
|
||||
cachedRunner <- atomically $ tryReadTMVar runnerTMVar
|
||||
case cachedRunner of
|
||||
Just cachedRunner' -> return cachedRunner'
|
||||
Nothing -> do
|
||||
runner <- doAcquire
|
||||
void . atomically $ tryPutTMVar runnerTMVar runner
|
||||
return runner
|
||||
getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar)
|
||||
-- let getRunner = bracket (atomically $ takeTMVar doAcquireLock) (void . atomically . tryPutTMVar doAcquireLock) . const $ do
|
||||
-- cachedRunner <- atomically $ tryReadTMVar runnerTMVar
|
||||
-- case cachedRunner of
|
||||
-- Just cachedRunner' -> return cachedRunner'
|
||||
-- Nothing -> do
|
||||
-- runner <- doAcquire
|
||||
-- void . atomically $ tryPutTMVar runnerTMVar runner
|
||||
-- return runner
|
||||
-- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar)
|
||||
|
||||
runCachedDBRunnerUsing act getRunnerNoLock
|
||||
-- runCachedDBRunnerUsing act getRunnerNoLock
|
||||
|
||||
Loading…
Reference in New Issue
Block a user