feat: load shedding
This commit is contained in:
Gregor Kleen
parent
30641a0d71
commit
9df0686086
@ -288,3 +288,5 @@ file-source-prewarm:
|
||||
|
||||
bot-mitigations:
|
||||
- only-logged-in-table-sorting
|
||||
|
||||
volatile-cluster-settings-cache-time: 10
|
||||
|
||||
@ -153,4 +153,6 @@ WorkflowInstanceUpdateNoActions: Keine Updates verfügbar
|
||||
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
|
||||
WorkflowInstanceUpdateUpdatedDescriptionLanguage lang@Lang: Beschreibung/Titel-Update für Sprache „#{lang}“ angewandt
|
||||
|
||||
WorkflowsDisabled: Workflows sind temporär deaktiviert.
|
||||
@ -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.
|
||||
@ -4,4 +4,10 @@ ClusterConfig
|
||||
setting ClusterSettingsKey -- I.e. Symmetric key for encrypting database-ids for use in URLs, Symmetric key for encrypting user-sessions so they can be saved directly as a browser-cookie, Symmetric key for encrypting error messages which might contain secret information, ...
|
||||
value Value -- JSON-encoded value
|
||||
Primary setting
|
||||
deriving Generic
|
||||
|
||||
VolatileClusterConfig
|
||||
setting VolatileClusterSettingsKey
|
||||
value Value
|
||||
Primary setting
|
||||
deriving Generic
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -2,6 +2,7 @@ module Foundation.DB
|
||||
( runDBRead, runDBRead'
|
||||
, runSqlPoolRetry, runSqlPoolRetry'
|
||||
, dbPoolPressured
|
||||
, runDBInternal, runDBInternal'
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (runDB, getDBRunner)
|
||||
@ -62,6 +63,15 @@ 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
|
||||
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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(..))
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
127
src/Settings/Cluster/Volatile.hs
Normal file
127
src/Settings/Cluster/Volatile.hs
Normal file
@ -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
|
||||
72
src/Utils/VolatileClusterSettings.hs
Normal file
72
src/Utils/VolatileClusterSettings.hs
Normal file
@ -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 ())
|
||||
Loading…
Reference in New Issue
Block a user