77 lines
2.7 KiB
Haskell
77 lines
2.7 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
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)
|
|
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 ())
|