diff --git a/config/settings.yml b/config/settings.yml index 7cefd42f4..9d2617e21 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -288,3 +288,5 @@ file-source-prewarm: bot-mitigations: - only-logged-in-table-sorting + +volatile-cluster-settings-cache-time: 10 diff --git a/messages/uniworx/categories/workflows/de-de-formal.msg b/messages/uniworx/categories/workflows/de-de-formal.msg index b9beb0e01..b875b5d8b 100644 --- a/messages/uniworx/categories/workflows/de-de-formal.msg +++ b/messages/uniworx/categories/workflows/de-de-formal.msg @@ -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 \ No newline at end of file +WorkflowInstanceUpdateUpdatedDescriptionLanguage lang@Lang: Beschreibung/Titel-Update für Sprache „#{lang}“ angewandt + +WorkflowsDisabled: Workflows sind temporär deaktiviert. \ No newline at end of file diff --git a/messages/uniworx/categories/workflows/en-eu.msg b/messages/uniworx/categories/workflows/en-eu.msg index 1a1225136..5fc8d4911 100644 --- a/messages/uniworx/categories/workflows/en-eu.msg +++ b/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. \ No newline at end of file diff --git a/models/config.model b/models/config.model index 202160cc7..2f91d9465 100644 --- a/models/config.model +++ b/models/config.model @@ -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 \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 9cd0fa810..7d02e6009 100644 --- a/src/Application.hs +++ b/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" diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index cef8e26ea..4c5cf6683 100644 --- a/src/Foundation/Authorization.hs +++ b/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 diff --git a/src/Foundation/DB.hs b/src/Foundation/DB.hs index 87f93a952..63993f607 100644 --- a/src/Foundation/DB.hs +++ b/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) @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index bb4baad68..541d9ff6d 100644 --- a/src/Foundation/Navigation.hs +++ b/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 diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index b8e1751c5..ebec84d65 100644 --- a/src/Foundation/SiteLayout.hs +++ b/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 diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 52be76c44..8a4a38c23 100644 --- a/src/Foundation/Type.hs +++ b/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 diff --git a/src/Import.hs b/src/Import.hs index ac410e50d..5eb5eb363 100644 --- a/src/Import.hs +++ b/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(..)) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 491f640f5..79a6a45ca 100644 --- a/src/Import/NoModel.hs +++ b/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) diff --git a/src/Settings.hs b/src/Settings.hs index dbb414987..743c0120a 100644 --- a/src/Settings.hs +++ b/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 diff --git a/src/Settings/Cluster/Volatile.hs b/src/Settings/Cluster/Volatile.hs new file mode 100644 index 000000000..802699cd1 --- /dev/null +++ b/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 diff --git a/src/Utils/VolatileClusterSettings.hs b/src/Utils/VolatileClusterSettings.hs new file mode 100644 index 000000000..7791133b9 --- /dev/null +++ b/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 ())