diff --git a/src/Foundation/DB.hs b/src/Foundation/DB.hs index 25cce0f45..87f93a952 100644 --- a/src/Foundation/DB.hs +++ b/src/Foundation/DB.hs @@ -1,6 +1,7 @@ module Foundation.DB ( runDBRead, runDBRead' , runSqlPoolRetry, runSqlPoolRetry' + , dbPoolPressured ) where import Import.NoFoundation hiding (runDB, getDBRunner) @@ -61,3 +62,13 @@ runDBRead' :: CallStack -> ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (Han runDBRead' lbl action = do $logDebugS "YesodPersist" "runDBRead" flip (runSqlPoolRetry' . withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action) lbl . appConnPool =<< getYesod + +dbPoolPressured :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => m Bool +dbPoolPressured = do + connPool <- getsYesod @_ @(Custom.Pool' IO _ _ _) appConnPool + case Custom.getPoolMaxAvailable connPool of + Nothing -> return False + Just lim -> atomically $ (>= lim) <$> Custom.getPoolInUseCount connPool diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index c21e114c5..f12782fbb 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -191,18 +191,21 @@ siteLayout' overrideHeading widget = do langs <- selectLanguages appLanguages <$> languages let cK = MemcachedKeyFavouriteQuickActions (tid, ssh, csh) ctx langs $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..." - items <- memcachedLimitedKeyTimeoutBy - MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1 - (Right <$> appFavouritesQuickActionsCacheTTL) - appFavouritesQuickActionsTimeout - cK - cK - . observeFavouritesQuickActionsDuration $ do - $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..." - items' <- pageQuickActions NavQuickViewFavourite courseRoute - items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n - $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." - return items + poolIsPressured <- dbPoolPressured + items <- if + | poolIsPressured -> Nothing <$ observeFavouritesSkippedDueToDBLoad + | otherwise -> memcachedLimitedKeyTimeoutBy + MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1 + (Right <$> appFavouritesQuickActionsCacheTTL) + appFavouritesQuickActionsTimeout + cK + cK + . observeFavouritesQuickActionsDuration $ do + $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..." + items' <- pageQuickActions NavQuickViewFavourite courseRoute + items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n + $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." + return items $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items) return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit) diff --git a/src/Handler/Utils/Database.hs b/src/Handler/Utils/Database.hs index b6f82ced0..bd6e81250 100644 --- a/src/Handler/Utils/Database.hs +++ b/src/Handler/Utils/Database.hs @@ -11,7 +11,6 @@ import Data.Map as Map -- import Data.CaseInsensitive (CI) -- import qualified Data.CaseInsensitive as CI - import qualified Database.Esqueleto as E makeSchoolDictionaryDB :: DB (Map.Map SchoolId SchoolName) diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index bba95d7b8..4a6347a39 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -25,6 +25,7 @@ module Utils.Metrics , observeDatabaseConnectionOpened, observeDatabaseConnectionClosed , onUseDBConn, onReleaseDBConn, DBConnUseState, DBConnLabel , AuthTagEvalOutcome(..), observeAuthTagEvaluation + , observeFavouritesSkippedDueToDBLoad ) where import Import.NoModel hiding (Vector, Info) @@ -259,6 +260,12 @@ missingFiles = unsafeRegister . vector "ref" $ gauge info where info = Info "uni2work_missing_files_count" "Number of files referenced from within database that are missing" +{-# NOINLINE favouritesSkippedDueToDBLoad #-} +favouritesSkippedDueToDBLoad :: Counter +favouritesSkippedDueToDBLoad = unsafeRegister $ counter info + where info = Info "uni2work_favourites_skipped_due_to_db_load_count" + "Number of times this Uni2work-instance skipped generating FavouriteQuickActions due to database pressure" + relabel :: Text -> Text -> SampleGroup -> SampleGroup relabel l s (SampleGroup i t ss) = SampleGroup i t . flip map ss $ \(Sample k lbls v) -> Sample k ((l, s) : filter (views _1 $ (/=) l) lbls) v @@ -592,3 +599,6 @@ observeAuthTagEvaluation aTag act = do liftIO . withLabel authTagEvaluationDuration (toPathPiece aTag, toPathPiece outcome) . flip observe . realToFrac $ end - start either throwIO (views _1 return) res + +observeFavouritesSkippedDueToDBLoad :: MonadIO m => m () +observeFavouritesSkippedDueToDBLoad = liftIO $ incCounter favouritesSkippedDueToDBLoad diff --git a/src/Utils/Pool.hs b/src/Utils/Pool.hs index e2031d89f..54b17a678 100644 --- a/src/Utils/Pool.hs +++ b/src/Utils/Pool.hs @@ -5,6 +5,7 @@ module Utils.Pool , PoolResourceIdent' , Pool, PoolResourceIdent , getPoolAvailableCount, getPoolInUseCount, getPoolUsesCount + , getPoolIdleTime, getPoolMaxAvailable , createPool, createPool' , purgePool , withResource, withResource' @@ -24,6 +25,7 @@ import UnliftIO.Concurrent (forkIO) import Data.Fixed import System.Clock +import Data.Time.Clock (DiffTime) import Control.Concurrent.STM.Delay import Control.Concurrent.STM.TVar (stateTVar) @@ -78,6 +80,10 @@ getPoolAvailableCount Pool{..} = availableCount <$> readTVar resources getPoolInUseCount Pool{..} = inUseCount <$> readTVar resources getPoolUsesCount Pool{..} = inUseTick <$> readTVar resources +getPoolIdleTime :: Pool' m c' c a -> Maybe DiffTime +getPoolIdleTime = fmap realToFrac . maxAvailable +getPoolMaxAvailable :: Pool' m c' c a -> Maybe Int +getPoolMaxAvailable = maxAvailable toSecond :: TimeSpec -> Int toSecond = fromIntegral . sec