feat: load shedding

config/settings.yml

@@ -288,3 +288,5 @@ file-source-prewarm:
 
 bot-mitigations:
   - only-logged-in-table-sorting
+
+volatile-cluster-settings-cache-time: 10

messages/uniworx/categories/workflows/de-de-formal.msg

@@ -154,3 +154,5 @@ WorkflowInstanceUpdateUpdatedGraph: Definitions-Update erfolgreich angewandt
 WorkflowInstanceUpdateUpdatedCategory: Kategorie-Update erfolgreich angewandt
 WorkflowInstanceUpdateDeletedDescriptionLanguage lang@Lang: Beschreibung/Titel in Sprache „#{lang}“ gelöscht
 WorkflowInstanceUpdateUpdatedDescriptionLanguage lang@Lang: Beschreibung/Titel-Update für Sprache „#{lang}“ angewandt
+
+WorkflowsDisabled: Workflows sind temporär deaktiviert.

messages/uniworx/categories/workflows/en-eu.msg

@@ -154,3 +154,5 @@ WorkflowInstanceUpdateUpdatedGraph: Successfully applied updated definition
 WorkflowInstanceUpdateUpdatedCategory: Successfully applied updated category
 WorkflowInstanceUpdateDeletedDescriptionLanguage lang: Successfully deleted description/title for language “#{lang}”
 WorkflowInstanceUpdateUpdatedDescriptionLanguage lang: Successfully applied updated description/title for language “#{lang}”
+
+WorkflowsDisabled: Workflows are temporarily disabled.

models/config.model

@@ -5,3 +5,9 @@ ClusterConfig
     value               Value              -- JSON-encoded value
     Primary setting
     deriving Generic
+
+VolatileClusterConfig
+    setting             VolatileClusterSettingsKey
+    value               Value
+    Primary setting
+    deriving Generic

src/Application.hs

@@ -116,6 +116,8 @@ import qualified Utils.Pool as Custom
 import Utils.Postgresql
 import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
 
+import qualified System.Clock as Clock
+
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.News
@@ -213,7 +215,7 @@ makeFoundation appSettings''@AppSettings{..} = do
     -- from there, and then create the real foundation.
     let
       mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _
-      mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey = UniWorX {..}
+      mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache = UniWorX {..}
       -- The UniWorX {..} syntax is an example of record wild cards. For more
       -- information, see:
       -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@@ -234,6 +236,7 @@ makeFoundation appSettings''@AppSettings{..} = do
         (error "VerpSecret forced in tempFoundation")
         (error "AuthKey forced in tempFoundation")
         (error "PersonalisedSheetFilesSeedKey forced in tempFoundation")
+        (error "VolatileClusterSettingsCache forced in tempFoundation")
 
     runAppLoggingT tempFoundation $ do
       $logInfoS "InstanceID" $ UUID.toText appInstanceID
@@ -296,6 +299,10 @@ makeFoundation appSettings''@AppSettings{..} = do
       appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `customRunSqlPool` sqlPool
       appPersonalisedSheetFilesSeedKey <- clusterSetting (Proxy :: Proxy 'ClusterPersonalisedSheetFilesSeedKey) `customRunSqlPool` sqlPool
 
+      let appVolatileClusterSettingsCacheTime' = Clock.fromNanoSecs ns
+            where (MkFixed ns :: Nano) = realToFrac appVolatileClusterSettingsCacheTime
+      appVolatileClusterSettingsCache <- newTVarIO $ mkVolatileClusterSettingsCache appVolatileClusterSettingsCacheTime'
+
       needsRechunk <- exists [FileContentChunkContentBased !=. True] `customRunSqlPool` sqlPool
       let appSettings' = appSettings''
             & _appRechunkFiles %~ guardOnM needsRechunk
@@ -328,7 +335,7 @@ makeFoundation appSettings''@AppSettings{..} = do
 
       $logDebugS "Runtime configuration" $ tshow appSettings'
 
-      let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey
+      let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache
 
       -- Return the foundation
       $logDebugS "setup" "Done"

src/Foundation/Authorization.hs

@@ -63,6 +63,8 @@ import qualified Data.Binary as Binary
 import GHC.TypeLits (TypeError)
 import qualified GHC.TypeLits as TypeError (ErrorMessage(..))
 
+import Utils.VolatileClusterSettings
+
 
 type BearerAuthSite site
   = ( MonadCrypto (HandlerFor site)
@@ -464,6 +466,11 @@ maybeCurrentBearerRestrictions = runMaybeT $ do
   route <- MaybeT getCurrentRoute
   hoistMaybe $ bearer ^? _bearerRestrictionIx route
 
+workflowsEnabledAuth :: (MonadHandler m, HandlerSite m ~ UniWorX)
+                     => m AuthResult
+                     -> m AuthResult
+workflowsEnabledAuth = volatileBool clusterVolatileWorkflowsEnabled (unauthorizedI MsgWorkflowsDisabled)
+
 data AuthorizationCacheKey
   = AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow
   | AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow
@@ -1543,7 +1550,7 @@ tagAccessPredicate AuthEmpty = APDB $ \evalCtx eval' mAuthId route _ -> do
       orAR' = shortCircuitM (is _Authorized) (orAR mr)
       _andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
 
-      workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $cachedHereBinary (evalCtx, mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
+      workflowInstanceWorkflowsEmpty rScope win = workflowsEnabledAuth $ selectLanguageI18n <=< $cachedHereBinary (evalCtx, mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
         roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ do
           scope <- fromRouteWorkflowScope rScope
           let dbScope = scope ^. _DBWorkflowScope
@@ -1712,7 +1719,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case rout
     guard $ not systemMessageAuthenticatedOnly || isAuthenticated
     return Authorized
   r -> $unsupportedAuthPredicate AuthAuthentication r
-tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> do
+tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> workflowsEnabledAuth $ do
   mr <- getMsgRenderer
   let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
       orAR' = shortCircuitM (is _Authorized) (orAR mr)
@@ -1979,7 +1986,7 @@ evalWorkflowRoleFor' :: forall m backend.
                      -> Route UniWorX
                      -> Bool
                      -> WriterT (Set AuthTag) (ReaderT backend m) AuthResult
-evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do
+evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = workflowsEnabledAuth $ do
   mr <- getMsgRenderer
 
   let
@@ -2028,7 +2035,7 @@ evalWorkflowRoleFor :: ( HasCallStack
                     -> Route UniWorX
                     -> Bool
                     -> ReaderT backend m AuthResult
-evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do
+evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = workflowsEnabledAuth $ do
   isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
   tagActive <- if
     | isSelf    -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
@@ -2052,7 +2059,7 @@ hasWorkflowRole :: ( HasCallStack
                 -> Route UniWorX
                 -> Bool
                 -> ReaderT backend m AuthResult
-hasWorkflowRole mwwId wRole route isWrite = do
+hasWorkflowRole mwwId wRole route isWrite = workflowsEnabledAuth $ do
   mAuthId <- maybeAuthId
   evalWorkflowRoleFor mAuthId mwwId wRole route isWrite
 
@@ -2070,7 +2077,7 @@ mayViewWorkflowAction' :: forall backend m fileid.
                        -> WorkflowWorkflowId
                        -> WorkflowAction fileid UserId
                        -> WriterT (Set AuthTag) (ReaderT backend m) Bool
-mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do
+mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = volatileBool clusterVolatileWorkflowsEnabled (return False) . hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do
   Entity _ WorkflowWorkflow{..} <- MaybeT . lift $ getWorkflowWorkflowState wwId
   rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
   cID <- catchMaybeT (Proxy @CryptoIDError) . lift . lift $ encrypt wwId
@@ -2100,7 +2107,7 @@ mayViewWorkflowAction :: forall backend m fileid.
                       -> WorkflowWorkflowId
                       -> WorkflowAction fileid UserId
                       -> ReaderT backend m Bool
-mayViewWorkflowAction mAuthId wwId act = do
+mayViewWorkflowAction mAuthId wwId act = volatileBool clusterVolatileWorkflowsEnabled (return False) $ do
   isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
   tagActive <- if
     | isSelf    -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags

src/Foundation/DB.hs

@@ -2,6 +2,7 @@ module Foundation.DB
   ( runDBRead, runDBRead'
   , runSqlPoolRetry, runSqlPoolRetry'
   , dbPoolPressured
+  , runDBInternal, runDBInternal'
   ) where
 
 import Import.NoFoundation hiding (runDB, getDBRunner)
@@ -63,6 +64,15 @@ runDBRead' lbl action = do
   $logDebugS "YesodPersist" "runDBRead"
   flip (runSqlPoolRetry' . withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action) lbl . appConnPool =<< getYesod
   
+runDBInternal :: HasCallStack
+              => ReaderT SqlBackend (HandlerFor UniWorX) a -> HandlerFor UniWorX a
+runDBInternal = runDBInternal' callStack
+
+runDBInternal' :: CallStack -> ReaderT SqlBackend (HandlerFor UniWorX) a -> HandlerFor UniWorX a
+runDBInternal' lbl action = do
+  $logDebugS "YesodPersist" "runDBInternal"
+  flip (runSqlPoolRetry' action) lbl . appConnPool =<< getYesod
+
 dbPoolPressured :: ( MonadHandler m
                    , HandlerSite m ~ UniWorX
                    )

src/Foundation/Navigation.hs

@@ -47,6 +47,8 @@ import qualified Data.Set as Set
 
 import Data.List (inits)
 
+import Utils.VolatileClusterSettings
+
 
 type Breadcrumb = (Text, Maybe (Route UniWorX))
   
@@ -758,6 +760,8 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
         }
       }
   , do
+      guardVolatile clusterVolatileWorkflowsEnabled
+      
       authCtx <- getAuthContext
       (haveInstances, haveWorkflows) <- lift . memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheHaveTopWorkflowsInstances authCtx) . useRunDB $ (,)
         <$> haveTopWorkflowInstances

src/Foundation/SiteLayout.hs

@@ -39,6 +39,9 @@ import Text.Cassius (cassiusFile)
 import Text.Hamlet (hamletFile)
 import Data.FileEmbed (embedFile)
 
+import Utils.VolatileClusterSettings
+
+
 data CourseFavouriteToggleButton
   = BtnCourseFavouriteToggleManual
   | BtnCourseFavouriteToggleAutomatic
@@ -303,7 +306,7 @@ siteLayout' overrideHeading widget = do
               let cK = MemcachedKeyFavouriteQuickActions (tid, ssh, csh) ctx langs
               $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
               poolIsPressured <- dbPoolPressured
-              items <- if
+              items <- volatileBool clusterVolatileQuickActionsEnabled (return Nothing) $ if
                 | poolIsPressured -> Nothing <$ observeFavouritesSkippedDueToDBLoad
                 | otherwise -> memcachedLimitedKeyTimeoutBy
                     MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1

src/Foundation/Type.hs

@@ -10,7 +10,7 @@ module Foundation.Type
   , AppMemcachedLocal(..)
   , _memcachedLocalARC
   , SMTPPool
-  , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey
+  , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache
   , DB, Form, MsgRenderer, MailM, DBFile
   ) where
 
@@ -95,6 +95,7 @@ data UniWorX = UniWorX
     , appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString)
     , appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference))
     , appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey
+    , appVolatileClusterSettingsCache :: TVar VolatileClusterSettingsCache
     } deriving (Typeable)
 
 makeLenses_ ''UniWorX

src/Import.hs

@@ -12,5 +12,6 @@ import Utils.Metrics         as Import
 import Utils.Files           as Import
 import Utils.PersistentTokenBucket as Import
 import Utils.Csv.Mail        as Import
+import Utils.VolatileClusterSettings as Import
 
 import Jobs.Types            as Import (JobHandler(..))

src/Import/NoModel.hs

@@ -46,6 +46,8 @@ import Utils.Sql              as Import
 import Utils.Widgets          as Import
 import Utils.Auth             as Import
 
+import Settings.Cluster.Volatile as Import
+
 import Data.Fixed             as Import
 
 import Data.UUID              as Import (UUID)

src/Settings.hs

@@ -222,6 +222,8 @@ data AppSettings = AppSettings
     , appFileSourcePrewarmConf  :: Maybe PrewarmCacheConf
 
     , appBotMitigations         :: Set SettingBotMitigation
+
+    , appVolatileClusterSettingsCacheTime :: DiffTime
     } deriving Show
 
 data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
@@ -678,6 +680,8 @@ instance FromJSON AppSettings where
 
         appBotMitigations <- o .:? "bot-mitigations" .!= Set.empty
 
+        appVolatileClusterSettingsCacheTime <- o .: "volatile-cluster-settings-cache-time"
+
         return AppSettings{..}
       where isValidARCConf ARCConf{..} = arccMaximumWeight > 0
 

src/Settings/Cluster/Volatile.hs

@@ -0,0 +1,127 @@
+module Settings.Cluster.Volatile
+  ( VolatileClusterSettingsKey(..)
+  , clusterVolatileWorkflowsEnabled, clusterVolatileQuickActionsEnabled
+  , VolatileClusterSetting(..)
+  , VolatileClusterSettingsCache
+  , mkVolatileClusterSettingsCache
+  , alterVolatileClusterSettingsCacheF, insertVolatileClusterSettingsCache, lookupVolatileClusterSettingsCache
+  ) where
+
+import ClassyPrelude.Yesod hiding (Proxy)
+
+import Data.HashPSQ (HashPSQ)
+import qualified Data.HashPSQ as HashPSQ
+
+import Data.Universe
+import Utils.PathPiece
+import Model.Types.TH.PathPiece
+  
+import Data.Kind (Type)
+import Data.Dynamic
+
+import System.Clock (TimeSpec)
+
+import Data.Functor.Const
+
+import Data.Proxy
+
+-- import Control.Lens
+
+
+data VolatileClusterSettingsKey
+  = ClusterVolatileWorkflowsEnabled
+  | ClusterVolatileQuickActionsEnabled
+  deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
+  deriving anyclass (Hashable, Universe, Finite, NFData)
+
+nullaryPathPiece ''VolatileClusterSettingsKey $ camelToPathPiece' 1
+pathPieceJSON ''VolatileClusterSettingsKey
+pathPieceJSONKey ''VolatileClusterSettingsKey
+pathPieceHttpApiData ''VolatileClusterSettingsKey
+derivePersistFieldPathPiece ''VolatileClusterSettingsKey
+
+clusterVolatileWorkflowsEnabled :: Proxy 'ClusterVolatileWorkflowsEnabled
+clusterVolatileWorkflowsEnabled = Proxy
+
+clusterVolatileQuickActionsEnabled :: Proxy 'ClusterVolatileQuickActionsEnabled
+clusterVolatileQuickActionsEnabled = Proxy
+
+
+class ( ToJSON (VolatileClusterSettingValue key)
+      , FromJSON (VolatileClusterSettingValue key)
+      , Typeable (VolatileClusterSettingValue key)
+      , NFData (VolatileClusterSettingValue key)
+      ) => VolatileClusterSetting (key :: VolatileClusterSettingsKey) where
+  type VolatileClusterSettingValue key :: Type
+  initVolatileClusterSetting :: forall m p. MonadIO m => p key -> m (VolatileClusterSettingValue key)
+  knownVolatileClusterSetting :: forall p. p key -> VolatileClusterSettingsKey
+
+instance VolatileClusterSetting 'ClusterVolatileWorkflowsEnabled where
+  type VolatileClusterSettingValue 'ClusterVolatileWorkflowsEnabled = Bool
+  initVolatileClusterSetting _ = return True
+  knownVolatileClusterSetting _ = ClusterVolatileWorkflowsEnabled
+
+instance VolatileClusterSetting 'ClusterVolatileQuickActionsEnabled where
+  type VolatileClusterSettingValue 'ClusterVolatileQuickActionsEnabled = Bool
+  initVolatileClusterSetting _ = return True
+  knownVolatileClusterSetting _ = ClusterVolatileQuickActionsEnabled
+
+
+data SomeVolatileClusterSettingsKey = forall key p. VolatileClusterSetting key => SomeVolatileClusterSettingsKey (p key)
+
+instance Eq SomeVolatileClusterSettingsKey where
+  (SomeVolatileClusterSettingsKey p1) == (SomeVolatileClusterSettingsKey p2) = knownVolatileClusterSetting p1 == knownVolatileClusterSetting p2
+instance Ord SomeVolatileClusterSettingsKey where
+  (SomeVolatileClusterSettingsKey p1) `compare` (SomeVolatileClusterSettingsKey p2) = knownVolatileClusterSetting p1 `compare` knownVolatileClusterSetting p2
+instance Hashable SomeVolatileClusterSettingsKey where
+  hashWithSalt s (SomeVolatileClusterSettingsKey p) = s `hashWithSalt` knownVolatileClusterSetting p
+
+data VolatileClusterSettingsCache = VolatileClusterSettingsCache
+  { volatileClusterSettingsCacheExpiry :: TimeSpec
+  , volatileClusterSettingsCacheCache :: HashPSQ SomeVolatileClusterSettingsKey TimeSpec Dynamic
+  }
+
+-- makePrisms ''VolatileClusterSettingsCache
+
+mkVolatileClusterSettingsCache :: TimeSpec -> VolatileClusterSettingsCache
+mkVolatileClusterSettingsCache volatileClusterSettingsCacheExpiry = VolatileClusterSettingsCache{..}
+  where volatileClusterSettingsCacheCache = HashPSQ.empty
+
+
+alterVolatileClusterSettingsCacheF :: forall key f p.
+                                      ( VolatileClusterSetting key
+                                      , Functor f
+                                      )
+                                   => p key
+                                   -> (Maybe (VolatileClusterSettingValue key) -> f (Maybe (VolatileClusterSettingValue key)))
+                                   -> VolatileClusterSettingsCache
+                                   -> TimeSpec -- ^ @now@
+                                   -> f VolatileClusterSettingsCache
+alterVolatileClusterSettingsCacheF p f c now
+    = f current <&> \new -> c { volatileClusterSettingsCacheCache = maybe (HashPSQ.delete k current') (\new' -> HashPSQ.insert k now (toDyn $!! new') current') new }
+  where
+    k = SomeVolatileClusterSettingsKey p
+    
+    cutoff = now - volatileClusterSettingsCacheExpiry c
+    
+    current' = volatileClusterSettingsCacheCache c
+    current = HashPSQ.lookup k current' >>= \(t, v) -> if
+      | t > cutoff -> fromDynamic v
+      | otherwise  -> Nothing
+
+insertVolatileClusterSettingsCache :: forall key p.
+                                      VolatileClusterSetting key
+                                   => p key
+                                   -> Maybe (VolatileClusterSettingValue key)
+                                   -> VolatileClusterSettingsCache
+                                   -> TimeSpec
+                                   -> VolatileClusterSettingsCache
+insertVolatileClusterSettingsCache k newVal = (runIdentity .) . alterVolatileClusterSettingsCacheF k (const $ pure newVal)
+
+lookupVolatileClusterSettingsCache :: forall key p.
+                                      VolatileClusterSetting key
+                                   => p key
+                                   -> VolatileClusterSettingsCache
+                                   -> TimeSpec
+                                   -> Maybe (VolatileClusterSettingValue key)
+lookupVolatileClusterSettingsCache k = (getConst .) . alterVolatileClusterSettingsCacheF k Const

src/Utils/VolatileClusterSettings.hs

@@ -0,0 +1,72 @@
+module Utils.VolatileClusterSettings
+  ( getVolatileClusterSetting
+  , VolatileClusterSettingException(..)
+  , whenVolatile, volatileBool, guardVolatile
+  ) where
+
+import Import.NoModel
+import Model
+import Foundation.Type
+import Foundation.DB
+
+import System.Clock
+
+import qualified Data.Aeson.Types as Aeson
+
+
+data VolatileClusterSettingException = VolatileClusterSettingExceptionNoParse
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Exception)
+
+  
+getVolatileClusterSetting :: forall key m p.
+                             ( VolatileClusterSetting key
+                             , MonadHandler m, HandlerSite m ~ UniWorX
+                             )
+                          => p key
+                          -> m (VolatileClusterSettingValue key)
+getVolatileClusterSetting p = exceptT return return $ do
+  cacheTVar <- getsYesod appVolatileClusterSettingsCache
+  now <- liftIO $ getTime Monotonic
+  oldVal <- flip (lookupVolatileClusterSettingsCache p) now <$> readTVarIO cacheTVar
+  traverse_ throwE oldVal
+  dbVal <- liftHandler . runDBInternal $ do
+    dbVal <- fmap (fmap volatileClusterConfigValue) . get . VolatileClusterConfigKey $ knownVolatileClusterSetting p
+    case dbVal of
+      Just v -> maybe (throwM VolatileClusterSettingExceptionNoParse) return $ Aeson.parseMaybe parseJSON v
+      Nothing -> do
+        newVal <- initVolatileClusterSetting p
+        insert_ $ VolatileClusterConfig (knownVolatileClusterSetting p) (toJSON newVal)
+        return newVal
+  atomically . modifyTVar' cacheTVar $ \c -> insertVolatileClusterSettingsCache p (Just dbVal) c now
+  return dbVal
+
+volatileBool :: forall key m a p.
+                ( VolatileClusterSetting key, VolatileClusterSettingValue key ~ Bool
+                , MonadHandler m, HandlerSite m ~ UniWorX
+                )
+             => p key
+             -> m a
+             -> m a
+             -> m a
+volatileBool p ifFalse ifTrue = do
+  r <- getVolatileClusterSetting p
+  bool ifFalse ifTrue r
+
+whenVolatile :: forall key m p.
+                ( VolatileClusterSetting key, VolatileClusterSettingValue key ~ Bool
+                , MonadHandler m, HandlerSite m ~ UniWorX
+                )
+             => p key
+             -> m ()
+             -> m ()
+whenVolatile p = volatileBool p (return ())
+
+guardVolatile :: forall key m p.
+                 ( VolatileClusterSetting key, VolatileClusterSettingValue key ~ Bool
+                 , MonadHandler m, HandlerSite m ~ UniWorX
+                 , MonadPlus m
+                 )
+              => p key
+              -> m ()
+guardVolatile p = volatileBool p mzero (return ())