123 lines
5.3 KiB
Haskell
123 lines
5.3 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Settings.Cluster.Volatile
|
|
( VolatileClusterSettingsKey(..)
|
|
, 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
|
|
= ClusterVolatileQuickActionsEnabled
|
|
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
|
deriving anyclass (Hashable, Universe, Finite, NFData)
|
|
|
|
nullaryPathPiece ''VolatileClusterSettingsKey $ camelToPathPiece' 2
|
|
pathPieceJSON ''VolatileClusterSettingsKey
|
|
pathPieceJSONKey ''VolatileClusterSettingsKey
|
|
pathPieceHttpApiData ''VolatileClusterSettingsKey
|
|
derivePersistFieldPathPiece ''VolatileClusterSettingsKey
|
|
|
|
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 '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
|