fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix: remove cached-db-runner

Browse Source 
Observed "connection disconnected" from persistent on 25.5.0
CachedDBRunner seemed suspicious.
This commit is contained in:
Gregor Kleen 2021-03-23 21:53:33 +01:00
parent 5786bc4032
commit ff8270042f
3 changed files with 71 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Foundation/SiteLayout.hs
View File

@ -222,7 +222,7 @@ siteLayout' overrideHeading widget = do
appFavouritesQuickActionsTimeout appFavouritesQuickActionsTimeout
cK cK
cK cK
. observeFavouritesQuickActionsDuration . runCachedDBRunner $ do . observeFavouritesQuickActionsDuration . runDBRead $ do
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..." $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
items' <- pageQuickActions NavQuickViewFavourite courseRoute items' <- pageQuickActions NavQuickViewFavourite courseRoute
items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n

50
src/Foundation/Yesod/Persist.hs
View File

@ -1,8 +1,8 @@
module Foundation.Yesod.Persist module Foundation.Yesod.Persist
( runDB, getDBRunner ( runDB, getDBRunner
, runDB', getDBRunner' , runDB', getDBRunner'
, runCachedDBRunner -- , runCachedDBRunner
, runCachedDBRunner' -- , runCachedDBRunner'
, module Foundation.DB , module Foundation.DB
) where ) where
@ -83,27 +83,27 @@ getDBRunner' lbl = do
runDBRunner action' runDBRunner action'
) )
runCachedDBRunner :: ( BackendCompatible backend (YesodPersistBackend UniWorX) -- runCachedDBRunner :: ( BackendCompatible backend (YesodPersistBackend UniWorX)
, YesodPersistBackend UniWorX ~ SqlBackend -- , YesodPersistBackend UniWorX ~ SqlBackend
, BearerAuthSite UniWorX -- , BearerAuthSite UniWorX
, HasCallStack -- , HasCallStack
) -- )
=> CachedDBRunner backend (HandlerFor UniWorX) a -- => CachedDBRunner backend (HandlerFor UniWorX) a
-> HandlerFor UniWorX a -- -> HandlerFor UniWorX a
runCachedDBRunner = runCachedDBRunner' callStack -- runCachedDBRunner = runCachedDBRunner' callStack
runCachedDBRunner' :: ( BackendCompatible backend (YesodPersistBackend UniWorX) -- runCachedDBRunner' :: ( BackendCompatible backend (YesodPersistBackend UniWorX)
, YesodPersistBackend UniWorX ~ SqlBackend -- , YesodPersistBackend UniWorX ~ SqlBackend
, BearerAuthSite UniWorX -- , BearerAuthSite UniWorX
) -- )
=> CallStack -- => CallStack
-> CachedDBRunner backend (HandlerFor UniWorX) a -- -> CachedDBRunner backend (HandlerFor UniWorX) a
-> HandlerFor UniWorX a -- -> HandlerFor UniWorX a
runCachedDBRunner' lbl act = do -- runCachedDBRunner' lbl act = do
cleanups <- newTVarIO [] -- cleanups <- newTVarIO []
res <- flip runCachedDBRunnerSTM act $ do -- res <- flip runCachedDBRunnerSTM act $ do
(runner, cleanup) <- getDBRunner' lbl -- (runner, cleanup) <- getDBRunner' lbl
atomically . modifyTVar' cleanups $ (:) cleanup -- atomically . modifyTVar' cleanups $ (:) cleanup
return $ fromDBRunner runner -- return $ fromDBRunner runner
mapM_ liftHandler =<< readTVarIO cleanups -- mapM_ liftHandler =<< readTVarIO cleanups
return res -- return res

90
src/Utils/DB.hs
View File

@ -20,10 +20,10 @@ import Database.Persist.Sql (runSqlConn)
import GHC.Stack (HasCallStack, CallStack, callStack) import GHC.Stack (HasCallStack, CallStack, callStack)
import Control.Monad.Fix (MonadFix) -- import Control.Monad.Fix (MonadFix)
import Control.Monad.Fail (MonadFail) -- import Control.Monad.Fail (MonadFail)
import Control.Monad.Trans.Reader (withReaderT) -- import Control.Monad.Trans.Reader (withReaderT)
emptyOrIn :: PersistField typ emptyOrIn :: PersistField typ
@ -188,56 +188,56 @@ class WithRunDB backend m' m | m -> backend m' where
instance WithRunDB backend m (ReaderT backend m) where instance WithRunDB backend m (ReaderT backend m) where
useRunDB = id 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' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site))
_DBRunner' = iso fromDBRunner' toDBRunner -- _DBRunner' = iso fromDBRunner' toDBRunner
where -- where
fromDBRunner' :: forall site. -- fromDBRunner' :: forall site.
DBRunner site -- DBRunner site
-> DBRunner' (YesodPersistBackend site) (HandlerFor site) -- -> DBRunner' (YesodPersistBackend site) (HandlerFor site)
fromDBRunner' DBRunner{..} = DBRunner' runDBRunner -- fromDBRunner' DBRunner{..} = DBRunner' runDBRunner
toDBRunner :: forall site. -- toDBRunner :: forall site.
DBRunner' (YesodPersistBackend site) (HandlerFor site) -- DBRunner' (YesodPersistBackend site) (HandlerFor site)
-> DBRunner site -- -> DBRunner site
toDBRunner DBRunner'{..} = DBRunner runDBRunner' -- toDBRunner DBRunner'{..} = DBRunner runDBRunner'
fromDBRunner :: BackendCompatible backend (YesodPersistBackend site) => DBRunner site -> DBRunner' backend (HandlerFor site) -- fromDBRunner :: BackendCompatible backend (YesodPersistBackend site) => DBRunner site -> DBRunner' backend (HandlerFor site)
fromDBRunner DBRunner{..} = DBRunner' (runDBRunner . withReaderT projectBackend) -- fromDBRunner DBRunner{..} = DBRunner' (runDBRunner . withReaderT projectBackend)
newtype CachedDBRunner backend m a = CachedDBRunner { runCachedDBRunnerUsing :: m (DBRunner' backend m) -> m a } -- 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) -- 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 -- instance MonadTrans (CachedDBRunner backend) where
lift act = CachedDBRunner (const act) -- lift act = CachedDBRunner (const act)
instance MonadHandler m => MonadHandler (CachedDBRunner backend m) where -- instance MonadHandler m => MonadHandler (CachedDBRunner backend m) where
type HandlerSite (CachedDBRunner backend m) = HandlerSite m -- type HandlerSite (CachedDBRunner backend m) = HandlerSite m
type SubHandlerSite (CachedDBRunner backend m) = SubHandlerSite m -- type SubHandlerSite (CachedDBRunner backend m) = SubHandlerSite m
liftHandler = lift . liftHandler -- liftHandler = lift . liftHandler
liftSubHandler = lift . liftSubHandler -- liftSubHandler = lift . liftSubHandler
instance Monad m => WithRunDB backend m (CachedDBRunner backend m) where -- instance Monad m => WithRunDB backend m (CachedDBRunner backend m) where
useRunDB act = CachedDBRunner (\getRunner -> getRunner >>= \DBRunner'{..} -> runDBRunner' act) -- useRunDB act = CachedDBRunner (\getRunner -> getRunner >>= \DBRunner'{..} -> runDBRunner' act)
runCachedDBRunnerSTM :: MonadUnliftIO m -- runCachedDBRunnerSTM :: MonadUnliftIO m
=> m (DBRunner' backend m) -- => m (DBRunner' backend m)
-> CachedDBRunner backend m a -- -> CachedDBRunner backend m a
-> m a -- -> m a
runCachedDBRunnerSTM doAcquire act = do -- runCachedDBRunnerSTM doAcquire act = do
doAcquireLock <- newTMVarIO () -- doAcquireLock <- newTMVarIO ()
runnerTMVar <- newEmptyTMVarIO -- runnerTMVar <- newEmptyTMVarIO
let getRunner = bracket (atomically $ takeTMVar doAcquireLock) (void . atomically . tryPutTMVar doAcquireLock) . const $ do -- let getRunner = bracket (atomically $ takeTMVar doAcquireLock) (void . atomically . tryPutTMVar doAcquireLock) . const $ do
cachedRunner <- atomically $ tryReadTMVar runnerTMVar -- cachedRunner <- atomically $ tryReadTMVar runnerTMVar
case cachedRunner of -- case cachedRunner of
Just cachedRunner' -> return cachedRunner' -- Just cachedRunner' -> return cachedRunner'
Nothing -> do -- Nothing -> do
runner <- doAcquire -- runner <- doAcquire
void . atomically $ tryPutTMVar runnerTMVar runner -- void . atomically $ tryPutTMVar runnerTMVar runner
return runner -- return runner
getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar) -- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar)
runCachedDBRunnerUsing act getRunnerNoLock -- runCachedDBRunnerUsing act getRunnerNoLock