perf: skip favouriteQuickActions under db conn pressure

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

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)
 

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)

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

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