From ff8270042f74d8019e121aebf8636472e1e4d79e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 23 Mar 2021 21:53:33 +0100 Subject: [PATCH] fix: remove cached-db-runner Observed "connection disconnected" from persistent on 25.5.0 CachedDBRunner seemed suspicious. --- src/Foundation/SiteLayout.hs | 2 +- src/Foundation/Yesod/Persist.hs | 50 +++++++++--------- src/Utils/DB.hs | 90 ++++++++++++++++----------------- 3 files changed, 71 insertions(+), 71 deletions(-) diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 28d4d1342..267f47385 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -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 diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs index 1ebc60983..6c7bccae4 100644 --- a/src/Foundation/Yesod/Persist.hs +++ b/src/Foundation/Yesod/Persist.hs @@ -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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index b0e48be1c..6c6e15c7b 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -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