{-# LANGUAGE NamedFieldPuns #-}

module LaunchDarkly.Server.Store.Internal
    ( isInitialized
    , getAllFlags
    , getFlag
    , getSegment
    , upsertFlag
    , upsertSegment
    , initialize
    , StoreResult
    , StoreResultM
    , PersistentDataStore (..)
    , SerializedItemDescriptor (..)
    , StoreHandle (..)
    , LaunchDarklyStoreRead (..)
    , LaunchDarklyStoreWrite (..)
    , ItemDescriptor (..)
    , makeStoreIO
    , insertFlag
    , deleteFlag
    , insertSegment
    , deleteSegment
    , initializeStore
    , createSerializedItemDescriptor
    , FeatureKey
    , FeatureNamespace
    , serializeWithPlaceholder
    , byteStringToVersionedData
    ) where

import Control.Lens (Lens', (%~), (^.))
import Control.Monad (void)
import Data.Aeson (FromJSON, ToJSON (toJSON), decode, encode)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.Function ((&))
import Data.Generics.Product (HasField', field, getField, setField)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Data.Maybe (isJust)
import Data.Text (Text)
import GHC.Generics (Generic)
import GHC.Natural (Natural)
import System.Clock (Clock (Monotonic), TimeSpec, getTime)

import Data.Aeson.Types (Value (Bool))
import Data.Either.Extra (eitherToMaybe)
import LaunchDarkly.AesonCompat (KeyMap, deleteKey, emptyObject, insertKey, lookupKey, mapMaybeValues, mapValues, singleton)
import LaunchDarkly.Server.Features (Flag, Segment)

-- Store result not defined in terms of StoreResultM so we dont have to export.
type StoreResultM m a = m (Either Text a)

-- |
-- The result type for every `PersistentDataStore` function. Instead of throwing
-- an exception, any store related error should return `Left`. Exceptions
-- unrelated to the store should not be caught.
type StoreResult a = IO (Either Text a)

class LaunchDarklyStoreRead store m where
    getFlagC :: store -> Text -> StoreResultM m (Maybe Flag)
    getSegmentC :: store -> Text -> StoreResultM m (Maybe Segment)
    getAllFlagsC :: store -> StoreResultM m (KeyMap Flag)
    getInitializedC :: store -> StoreResultM m Bool

class LaunchDarklyStoreWrite store m where
    storeInitializeC :: store -> KeyMap (ItemDescriptor Flag) -> KeyMap (ItemDescriptor Segment) -> StoreResultM m ()
    upsertSegmentC :: store -> Text -> ItemDescriptor (Maybe Segment) -> StoreResultM m ()
    upsertFlagC :: store -> Text -> ItemDescriptor (Maybe Flag) -> StoreResultM m ()

data StoreHandle m = StoreHandle
    { forall (m :: * -> *).
StoreHandle m -> Text -> StoreResultM m (Maybe Flag)
storeHandleGetFlag :: !(Text -> StoreResultM m (Maybe Flag))
    , forall (m :: * -> *).
StoreHandle m -> Text -> StoreResultM m (Maybe Segment)
storeHandleGetSegment :: !(Text -> StoreResultM m (Maybe Segment))
    , forall (m :: * -> *). StoreHandle m -> StoreResultM m (KeyMap Flag)
storeHandleAllFlags :: !(StoreResultM m (KeyMap Flag))
    , forall (m :: * -> *). StoreHandle m -> StoreResultM m Bool
storeHandleInitialized :: !(StoreResultM m Bool)
    , forall (m :: * -> *).
StoreHandle m
-> KeyMap (ItemDescriptor Flag)
-> KeyMap (ItemDescriptor Segment)
-> StoreResultM m ()
storeHandleInitialize :: !(KeyMap (ItemDescriptor Flag) -> KeyMap (ItemDescriptor Segment) -> StoreResultM m ())
    , forall (m :: * -> *).
StoreHandle m
-> Text -> ItemDescriptor (Maybe Segment) -> StoreResultM m ()
storeHandleUpsertSegment :: !(Text -> ItemDescriptor (Maybe Segment) -> StoreResultM m ())
    , forall (m :: * -> *).
StoreHandle m
-> Text -> ItemDescriptor (Maybe Flag) -> StoreResultM m ()
storeHandleUpsertFlag :: !(Text -> ItemDescriptor (Maybe Flag) -> StoreResultM m ())
    , forall (m :: * -> *). StoreHandle m -> StoreResultM m ()
storeHandleExpireAll :: !(StoreResultM m ())
    }
    deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) x. Rep (StoreHandle m) x -> StoreHandle m
forall (m :: * -> *) x. StoreHandle m -> Rep (StoreHandle m) x
$cto :: forall (m :: * -> *) x. Rep (StoreHandle m) x -> StoreHandle m
$cfrom :: forall (m :: * -> *) x. StoreHandle m -> Rep (StoreHandle m) x
Generic)

instance Monad m => LaunchDarklyStoreRead (StoreHandle m) m where
    getFlagC :: StoreHandle m -> Text -> StoreResultM m (Maybe Flag)
getFlagC = forall (m :: * -> *).
StoreHandle m -> Text -> StoreResultM m (Maybe Flag)
storeHandleGetFlag
    getSegmentC :: StoreHandle m -> Text -> StoreResultM m (Maybe Segment)
getSegmentC = forall (m :: * -> *).
StoreHandle m -> Text -> StoreResultM m (Maybe Segment)
storeHandleGetSegment
    getAllFlagsC :: StoreHandle m -> StoreResultM m (KeyMap Flag)
getAllFlagsC = forall (m :: * -> *). StoreHandle m -> StoreResultM m (KeyMap Flag)
storeHandleAllFlags
    getInitializedC :: StoreHandle m -> StoreResultM m Bool
getInitializedC = forall (m :: * -> *). StoreHandle m -> StoreResultM m Bool
storeHandleInitialized

instance Monad m => LaunchDarklyStoreWrite (StoreHandle m) m where
    storeInitializeC :: StoreHandle m
-> KeyMap (ItemDescriptor Flag)
-> KeyMap (ItemDescriptor Segment)
-> StoreResultM m ()
storeInitializeC = forall (m :: * -> *).
StoreHandle m
-> KeyMap (ItemDescriptor Flag)
-> KeyMap (ItemDescriptor Segment)
-> StoreResultM m ()
storeHandleInitialize
    upsertSegmentC :: StoreHandle m
-> Text -> ItemDescriptor (Maybe Segment) -> StoreResultM m ()
upsertSegmentC = forall (m :: * -> *).
StoreHandle m
-> Text -> ItemDescriptor (Maybe Segment) -> StoreResultM m ()
storeHandleUpsertSegment
    upsertFlagC :: StoreHandle m
-> Text -> ItemDescriptor (Maybe Flag) -> StoreResultM m ()
upsertFlagC = forall (m :: * -> *).
StoreHandle m
-> Text -> ItemDescriptor (Maybe Flag) -> StoreResultM m ()
storeHandleUpsertFlag

initializeStore ::
    (LaunchDarklyStoreWrite store m, Monad m) =>
    store ->
    KeyMap Flag ->
    KeyMap Segment ->
    StoreResultM m ()
initializeStore :: forall store (m :: * -> *).
(LaunchDarklyStoreWrite store m, Monad m) =>
store -> KeyMap Flag -> KeyMap Segment -> StoreResultM m ()
initializeStore store
store KeyMap Flag
flags KeyMap Segment
segments = forall store (m :: * -> *).
LaunchDarklyStoreWrite store m =>
store
-> KeyMap (ItemDescriptor Flag)
-> KeyMap (ItemDescriptor Segment)
-> StoreResultM m ()
storeInitializeC store
store (forall {s}.
HasField' "version" s Natural =>
KeyMap s -> KeyMap (ItemDescriptor s)
makeVersioned KeyMap Flag
flags) (forall {s}.
HasField' "version" s Natural =>
KeyMap s -> KeyMap (ItemDescriptor s)
makeVersioned KeyMap Segment
segments)
  where
    makeVersioned :: KeyMap s -> KeyMap (ItemDescriptor s)
makeVersioned = forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues (\s
f -> forall a. a -> Natural -> ItemDescriptor a
ItemDescriptor s
f (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"version" s
f))

insertFlag :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Flag -> StoreResultM m ()
insertFlag :: forall store (m :: * -> *).
(LaunchDarklyStoreWrite store m, Monad m) =>
store -> Flag -> StoreResultM m ()
insertFlag store
store Flag
flag = forall store (m :: * -> *).
LaunchDarklyStoreWrite store m =>
store -> Text -> ItemDescriptor (Maybe Flag) -> StoreResultM m ()
upsertFlagC store
store (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"key" Flag
flag) forall a b. (a -> b) -> a -> b
$ forall a. a -> Natural -> ItemDescriptor a
ItemDescriptor (forall (f :: * -> *) a. Applicative f => a -> f a
pure Flag
flag) (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"version" Flag
flag)

deleteFlag :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Text -> Natural -> StoreResultM m ()
deleteFlag :: forall store (m :: * -> *).
(LaunchDarklyStoreWrite store m, Monad m) =>
store -> Text -> Natural -> StoreResultM m ()
deleteFlag store
store Text
key Natural
version = forall store (m :: * -> *).
LaunchDarklyStoreWrite store m =>
store -> Text -> ItemDescriptor (Maybe Flag) -> StoreResultM m ()
upsertFlagC store
store Text
key forall a b. (a -> b) -> a -> b
$ forall a. a -> Natural -> ItemDescriptor a
ItemDescriptor forall a. Maybe a
Nothing Natural
version

insertSegment :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Segment -> StoreResultM m ()
insertSegment :: forall store (m :: * -> *).
(LaunchDarklyStoreWrite store m, Monad m) =>
store -> Segment -> StoreResultM m ()
insertSegment store
store Segment
segment = forall store (m :: * -> *).
LaunchDarklyStoreWrite store m =>
store
-> Text -> ItemDescriptor (Maybe Segment) -> StoreResultM m ()
upsertSegmentC store
store (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"key" Segment
segment) forall a b. (a -> b) -> a -> b
$ forall a. a -> Natural -> ItemDescriptor a
ItemDescriptor (forall (f :: * -> *) a. Applicative f => a -> f a
pure Segment
segment) (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"version" Segment
segment)

deleteSegment :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Text -> Natural -> StoreResultM m ()
deleteSegment :: forall store (m :: * -> *).
(LaunchDarklyStoreWrite store m, Monad m) =>
store -> Text -> Natural -> StoreResultM m ()
deleteSegment store
store Text
key Natural
version = forall store (m :: * -> *).
LaunchDarklyStoreWrite store m =>
store
-> Text -> ItemDescriptor (Maybe Segment) -> StoreResultM m ()
upsertSegmentC store
store Text
key forall a b. (a -> b) -> a -> b
$ forall a. a -> Natural -> ItemDescriptor a
ItemDescriptor forall a. Maybe a
Nothing Natural
version

makeStoreIO :: Maybe PersistentDataStore -> TimeSpec -> IO (StoreHandle IO)
makeStoreIO :: Maybe PersistentDataStore -> TimeSpec -> IO (StoreHandle IO)
makeStoreIO Maybe PersistentDataStore
backend TimeSpec
ttl = do
    IORef State
state <-
        forall a. a -> IO (IORef a)
newIORef
            State
                { $sel:allFlags:State :: Expirable (KeyMap Flag)
allFlags = forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable forall v. KeyMap v
emptyObject Bool
True TimeSpec
0
                , $sel:features:State :: KeyMap (Expirable (CacheableItem Flag))
features = forall v. KeyMap v
emptyObject
                , $sel:segments:State :: KeyMap (Expirable (CacheableItem Segment))
segments = forall v. KeyMap v
emptyObject
                , $sel:initialized:State :: Expirable Bool
initialized = forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable Bool
False Bool
True TimeSpec
0
                }
    let store :: Store
store = IORef State -> Maybe PersistentDataStore -> TimeSpec -> Store
Store IORef State
state Maybe PersistentDataStore
backend TimeSpec
ttl
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        StoreHandle
            { $sel:storeHandleGetFlag:StoreHandle :: Text -> StoreResultM IO (Maybe Flag)
storeHandleGetFlag = Store -> Text -> StoreResultM IO (Maybe Flag)
getFlag Store
store
            , $sel:storeHandleGetSegment:StoreHandle :: Text -> StoreResultM IO (Maybe Segment)
storeHandleGetSegment = Store -> Text -> StoreResultM IO (Maybe Segment)
getSegment Store
store
            , $sel:storeHandleAllFlags:StoreHandle :: StoreResultM IO (KeyMap Flag)
storeHandleAllFlags = Store -> StoreResultM IO (KeyMap Flag)
getAllFlags Store
store
            , $sel:storeHandleInitialized:StoreHandle :: StoreResultM IO Bool
storeHandleInitialized = Store -> StoreResultM IO Bool
isInitialized Store
store
            , $sel:storeHandleInitialize:StoreHandle :: KeyMap (ItemDescriptor Flag)
-> KeyMap (ItemDescriptor Segment) -> StoreResultM IO ()
storeHandleInitialize = Store
-> KeyMap (ItemDescriptor Flag)
-> KeyMap (ItemDescriptor Segment)
-> StoreResultM IO ()
initialize Store
store
            , $sel:storeHandleUpsertSegment:StoreHandle :: Text -> ItemDescriptor (Maybe Segment) -> StoreResultM IO ()
storeHandleUpsertSegment = Store
-> Text -> ItemDescriptor (Maybe Segment) -> StoreResultM IO ()
upsertSegment Store
store
            , $sel:storeHandleUpsertFlag:StoreHandle :: Text -> ItemDescriptor (Maybe Flag) -> StoreResultM IO ()
storeHandleUpsertFlag = Store -> Text -> ItemDescriptor (Maybe Flag) -> StoreResultM IO ()
upsertFlag Store
store
            , $sel:storeHandleExpireAll:StoreHandle :: StoreResultM IO ()
storeHandleExpireAll = Store -> IO ()
expireAllItems Store
store forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ())
            }

data Expirable a = Expirable
    { forall a. Expirable a -> a
value :: !a
    , forall a. Expirable a -> Bool
forceExpire :: !Bool
    , forall a. Expirable a -> TimeSpec
updatedOn :: !TimeSpec
    }
    deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Expirable a) x -> Expirable a
forall a x. Expirable a -> Rep (Expirable a) x
$cto :: forall a x. Rep (Expirable a) x -> Expirable a
$cfrom :: forall a x. Expirable a -> Rep (Expirable a) x
Generic)

data ItemDescriptor a = ItemDescriptor
    { forall a. ItemDescriptor a -> a
value :: !a
    , forall a. ItemDescriptor a -> Natural
version :: !Natural
    }
    deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ItemDescriptor a) x -> ItemDescriptor a
forall a x. ItemDescriptor a -> Rep (ItemDescriptor a) x
$cto :: forall a x. Rep (ItemDescriptor a) x -> ItemDescriptor a
$cfrom :: forall a x. ItemDescriptor a -> Rep (ItemDescriptor a) x
Generic)

-- The CacheableItem is used to store results from a persistent store.
--
-- The type is a Maybe because it is possible that a persistent store will not
-- have a record of a flag requested. We can store that result as a Nothing and
-- prevent subsequent evaluations from reaching across the network.
type CacheableItem a = Maybe (ItemDescriptor (Maybe a))

data State = State
    { State -> Expirable (KeyMap Flag)
allFlags :: !(Expirable (KeyMap Flag))
    , State -> KeyMap (Expirable (CacheableItem Flag))
features :: !(KeyMap (Expirable (CacheableItem Flag)))
    , State -> KeyMap (Expirable (CacheableItem Segment))
segments :: !(KeyMap (Expirable (CacheableItem Segment)))
    , State -> Expirable Bool
initialized :: !(Expirable Bool)
    }
    deriving (forall x. Rep State x -> State
forall x. State -> Rep State x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep State x -> State
$cfrom :: forall x. State -> Rep State x
Generic)

-- | Represents the key for a given feature.
type FeatureKey = Text

-- | Represents a namespace such as features or segments
type FeatureNamespace = Text

-- | The interface implemented by external stores for use by the SDK.
data PersistentDataStore = PersistentDataStore
    { PersistentDataStore
-> Text -> StoreResult (KeyMap SerializedItemDescriptor)
persistentDataStoreAllFeatures :: !(FeatureNamespace -> StoreResult (KeyMap SerializedItemDescriptor))
    -- ^ A map of all features in a given namespace including deleted.
    , PersistentDataStore
-> Text -> Text -> StoreResult (Maybe SerializedItemDescriptor)
persistentDataStoreGetFeature :: !(FeatureNamespace -> FeatureKey -> StoreResult (Maybe SerializedItemDescriptor))
    -- ^ Return the value of a key in a namespace.
    , PersistentDataStore
-> Text -> Text -> SerializedItemDescriptor -> StoreResultM IO Bool
persistentDataStoreUpsertFeature :: !(FeatureNamespace -> FeatureKey -> SerializedItemDescriptor -> StoreResult Bool)
    -- ^ Upsert a given feature. Versions should be compared before upsert.
    -- The result should indicate if the feature was replaced or not.
    , PersistentDataStore -> StoreResultM IO Bool
persistentDataStoreIsInitialized :: !(StoreResult Bool)
    -- ^ Checks if the external store has been initialized, which may
    -- have been done by another instance of the SDK.
    , PersistentDataStore
-> KeyMap (KeyMap SerializedItemDescriptor) -> StoreResultM IO ()
persistentDataStoreInitialize :: !(KeyMap (KeyMap SerializedItemDescriptor) -> StoreResult ())
    -- ^ A map of namespaces, and items in namespaces. The entire store state
    -- should be replaced with these values.
    }

-- | A record representing an object that can be persisted in an external store.
data SerializedItemDescriptor = SerializedItemDescriptor
    { SerializedItemDescriptor -> Maybe ByteString
item :: !(Maybe ByteString)
    -- ^ A serialized item. If the item is deleted or does not exist this
    -- should be `Nothing`.
    , SerializedItemDescriptor -> Natural
version :: !Natural
    -- ^ The version of a given item. If the item does not exist this should
    -- be zero.
    , SerializedItemDescriptor -> Bool
deleted :: !Bool
    -- ^ True if this is a placeholder (tombstone) for a deleted item.
    }
    deriving (forall x.
Rep SerializedItemDescriptor x -> SerializedItemDescriptor
forall x.
SerializedItemDescriptor -> Rep SerializedItemDescriptor x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep SerializedItemDescriptor x -> SerializedItemDescriptor
$cfrom :: forall x.
SerializedItemDescriptor -> Rep SerializedItemDescriptor x
Generic, SerializedItemDescriptor -> SerializedItemDescriptor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SerializedItemDescriptor -> SerializedItemDescriptor -> Bool
$c/= :: SerializedItemDescriptor -> SerializedItemDescriptor -> Bool
== :: SerializedItemDescriptor -> SerializedItemDescriptor -> Bool
$c== :: SerializedItemDescriptor -> SerializedItemDescriptor -> Bool
Eq, Int -> SerializedItemDescriptor -> ShowS
[SerializedItemDescriptor] -> ShowS
SerializedItemDescriptor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SerializedItemDescriptor] -> ShowS
$cshowList :: [SerializedItemDescriptor] -> ShowS
show :: SerializedItemDescriptor -> String
$cshow :: SerializedItemDescriptor -> String
showsPrec :: Int -> SerializedItemDescriptor -> ShowS
$cshowsPrec :: Int -> SerializedItemDescriptor -> ShowS
Show)

-- |
-- Generate a 'ByteString' representation of the 'SerializedItemDescriptor'.
--
-- If the 'SerializedItemDescriptor' has either a 'Nothing' value, or is marked
-- as deleted, the ByteString representation will be a tombstone marker containing the version and deletion status.
--
-- Otherwise, the internal item representation is returned.
serializeWithPlaceholder :: SerializedItemDescriptor -> ByteString
serializeWithPlaceholder :: SerializedItemDescriptor -> ByteString
serializeWithPlaceholder SerializedItemDescriptor {$sel:item:SerializedItemDescriptor :: SerializedItemDescriptor -> Maybe ByteString
item = Maybe ByteString
Nothing, $sel:version:SerializedItemDescriptor :: SerializedItemDescriptor -> Natural
version = Natural
version} = Natural -> ByteString
tombstonePlaceholder Natural
version
serializeWithPlaceholder SerializedItemDescriptor {$sel:deleted:SerializedItemDescriptor :: SerializedItemDescriptor -> Bool
deleted = Bool
True, $sel:version:SerializedItemDescriptor :: SerializedItemDescriptor -> Natural
version = Natural
version} = Natural -> ByteString
tombstonePlaceholder Natural
version
serializeWithPlaceholder SerializedItemDescriptor {$sel:item:SerializedItemDescriptor :: SerializedItemDescriptor -> Maybe ByteString
item = Just ByteString
item} = ByteString
item

-- Generate the tombstone placeholder ByteString representation.
tombstonePlaceholder :: Natural -> ByteString
tombstonePlaceholder :: Natural -> ByteString
tombstonePlaceholder Natural
version = forall v. Text -> v -> KeyMap v
singleton Text
"deleted" (Bool -> Value
Bool Bool
True) forall a b. a -> (a -> b) -> b
& forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
"version" (forall a. ToJSON a => a -> Value
toJSON Natural
version) forall a b. a -> (a -> b) -> b
& forall a. ToJSON a => a -> ByteString
encode forall a b. a -> (a -> b) -> b
& ByteString -> ByteString
toStrict

-- |
-- Partially decode the provided ByteString into a 'VersionedData' struct.
--
-- This is useful for persistent stores who need to perform version comparsions
-- before persisting data.
byteStringToVersionedData :: ByteString -> Maybe VersionedData
byteStringToVersionedData :: ByteString -> Maybe VersionedData
byteStringToVersionedData ByteString
byteString = forall a. FromJSON a => ByteString -> Maybe a
decode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict ByteString
byteString

data VersionedData = VersionedData
    { VersionedData -> Natural
version :: !Natural
    , VersionedData -> Bool
deleted :: !Bool
    }
    deriving (forall x. Rep VersionedData x -> VersionedData
forall x. VersionedData -> Rep VersionedData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VersionedData x -> VersionedData
$cfrom :: forall x. VersionedData -> Rep VersionedData x
Generic, [VersionedData] -> Encoding
[VersionedData] -> Value
VersionedData -> Encoding
VersionedData -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [VersionedData] -> Encoding
$ctoEncodingList :: [VersionedData] -> Encoding
toJSONList :: [VersionedData] -> Value
$ctoJSONList :: [VersionedData] -> Value
toEncoding :: VersionedData -> Encoding
$ctoEncoding :: VersionedData -> Encoding
toJSON :: VersionedData -> Value
$ctoJSON :: VersionedData -> Value
ToJSON, Value -> Parser [VersionedData]
Value -> Parser VersionedData
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [VersionedData]
$cparseJSONList :: Value -> Parser [VersionedData]
parseJSON :: Value -> Parser VersionedData
$cparseJSON :: Value -> Parser VersionedData
FromJSON)

data Store = Store
    { Store -> IORef State
state :: !(IORef State)
    , Store -> Maybe PersistentDataStore
backend :: !(Maybe PersistentDataStore)
    , Store -> TimeSpec
timeToLive :: !TimeSpec
    }
    deriving (forall x. Rep Store x -> Store
forall x. Store -> Rep Store x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Store x -> Store
$cfrom :: forall x. Store -> Rep Store x
Generic)

expireAllItems :: Store -> IO ()
expireAllItems :: Store -> IO ()
expireAllItems Store
store = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store) forall a b. (a -> b) -> a -> b
$ \State
state ->
    (,()) forall a b. (a -> b) -> a -> b
$
        State
state
            forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"allFlags" forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {s}. HasField' "forceExpire" s Bool => s -> s
expire
            forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"initialized" forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {s}. HasField' "forceExpire" s Bool => s -> s
expire
            forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"features" forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues forall {s}. HasField' "forceExpire" s Bool => s -> s
expire
            forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"segments" forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues forall {s}. HasField' "forceExpire" s Bool => s -> s
expire
  where
    expire :: s -> s
expire = forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"forceExpire" Bool
True

isExpired :: Store -> TimeSpec -> Expirable a -> Bool
isExpired :: forall a. Store -> TimeSpec -> Expirable a -> Bool
isExpired Store
store TimeSpec
now Expirable a
item =
    (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"backend" Store
store)
        Bool -> Bool -> Bool
&& ( (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"forceExpire" Expirable a
item)
                Bool -> Bool -> Bool
|| (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"timeToLive" Store
store) forall a. Num a => a -> a -> a
+ (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"updatedOn" Expirable a
item) forall a. Ord a => a -> a -> Bool
< TimeSpec
now
           )

getMonotonicTime :: IO TimeSpec
getMonotonicTime :: IO TimeSpec
getMonotonicTime = Clock -> IO TimeSpec
getTime Clock
Monotonic

initialize :: Store -> KeyMap (ItemDescriptor Flag) -> KeyMap (ItemDescriptor Segment) -> StoreResult ()
initialize :: Store
-> KeyMap (ItemDescriptor Flag)
-> KeyMap (ItemDescriptor Segment)
-> StoreResultM IO ()
initialize Store
store KeyMap (ItemDescriptor Flag)
flags KeyMap (ItemDescriptor Segment)
segments = case forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"backend" Store
store of
    Maybe PersistentDataStore
Nothing -> do
        forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store) forall a b. (a -> b) -> a -> b
$ \State
state ->
            (,()) forall a b. (a -> b) -> a -> b
$
                State
state
                    forall a b. a -> (a -> b) -> b
& forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"features" (forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues (\ItemDescriptor (Maybe Flag)
f -> forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable (forall a. a -> Maybe a
Just ItemDescriptor (Maybe Flag)
f) Bool
True TimeSpec
0) forall a b. (a -> b) -> a -> b
$ forall {a} {v2} {a}.
HasField "value" a v2 a (Maybe a) =>
KeyMap a -> KeyMap v2
c KeyMap (ItemDescriptor Flag)
flags)
                    forall a b. a -> (a -> b) -> b
& forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"segments" (forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues (\ItemDescriptor (Maybe Segment)
f -> forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable (forall a. a -> Maybe a
Just ItemDescriptor (Maybe Segment)
f) Bool
True TimeSpec
0) forall a b. (a -> b) -> a -> b
$ forall {a} {v2} {a}.
HasField "value" a v2 a (Maybe a) =>
KeyMap a -> KeyMap v2
c KeyMap (ItemDescriptor Segment)
segments)
                    forall a b. a -> (a -> b) -> b
& forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"allFlags" (forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable (forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value") KeyMap (ItemDescriptor Flag)
flags) Bool
True TimeSpec
0)
                    forall a b. a -> (a -> b) -> b
& forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"initialized" (forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable Bool
True Bool
False TimeSpec
0)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
    Just PersistentDataStore
backend ->
        (PersistentDataStore
-> KeyMap (KeyMap SerializedItemDescriptor) -> StoreResultM IO ()
persistentDataStoreInitialize PersistentDataStore
backend) KeyMap (KeyMap SerializedItemDescriptor)
serializedItemMap forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left Text
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
err
            Right () -> Store -> IO ()
expireAllItems Store
store forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ())
  where
    serializedItemMap :: KeyMap (KeyMap SerializedItemDescriptor)
serializedItemMap =
        forall v. KeyMap v
emptyObject
            forall a b. a -> (a -> b) -> b
& forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
"features" (forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues forall a.
ToJSON a =>
ItemDescriptor (Maybe a) -> SerializedItemDescriptor
createSerializedItemDescriptor forall a b. (a -> b) -> a -> b
$ forall {a} {v2} {a}.
HasField "value" a v2 a (Maybe a) =>
KeyMap a -> KeyMap v2
c KeyMap (ItemDescriptor Flag)
flags)
            forall a b. a -> (a -> b) -> b
& forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
"segments" (forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues forall a.
ToJSON a =>
ItemDescriptor (Maybe a) -> SerializedItemDescriptor
createSerializedItemDescriptor forall a b. (a -> b) -> a -> b
$ forall {a} {v2} {a}.
HasField "value" a v2 a (Maybe a) =>
KeyMap a -> KeyMap v2
c KeyMap (ItemDescriptor Segment)
segments)
    c :: KeyMap a -> KeyMap v2
c KeyMap a
x = forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues (\a
f -> a
f forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"value" forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. a -> Maybe a
Just) KeyMap a
x

serializedToItemDescriptor :: (FromJSON a, HasField' "version" a Natural) => SerializedItemDescriptor -> Either Text (ItemDescriptor (Maybe a))
serializedToItemDescriptor :: forall a.
(FromJSON a, HasField' "version" a Natural) =>
SerializedItemDescriptor -> Either Text (ItemDescriptor (Maybe a))
serializedToItemDescriptor SerializedItemDescriptor
serializedItem = case forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"item" SerializedItemDescriptor
serializedItem of
    Maybe ByteString
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Natural -> ItemDescriptor a
ItemDescriptor forall a. Maybe a
Nothing (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"version" SerializedItemDescriptor
serializedItem)
    Just ByteString
buffer -> do
        let versionedData :: Maybe VersionedData
versionedData = ByteString -> Maybe VersionedData
byteStringToVersionedData ByteString
buffer
         in case Maybe VersionedData
versionedData of
                Maybe VersionedData
Nothing -> forall a b. a -> Either a b
Left Text
"failed decoding into VersionedData"
                Just VersionedData {$sel:deleted:VersionedData :: VersionedData -> Bool
deleted = Bool
True, $sel:version:VersionedData :: VersionedData -> Natural
version = Natural
version} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Natural -> ItemDescriptor a
ItemDescriptor forall a. Maybe a
Nothing Natural
version
                Just VersionedData
_ ->
                    let decodeResult :: Maybe a
decodeResult = forall a. FromJSON a => ByteString -> Maybe a
decode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict ByteString
buffer
                     in case Maybe a
decodeResult of
                            Maybe a
Nothing -> forall a b. a -> Either a b
Left Text
"failed decoding into ItemDescriptor"
                            Just a
decoded -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Natural -> ItemDescriptor a
ItemDescriptor (forall a. a -> Maybe a
Just a
decoded) (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"version" a
decoded)

createSerializedItemDescriptor :: (ToJSON a) => ItemDescriptor (Maybe a) -> SerializedItemDescriptor
createSerializedItemDescriptor :: forall a.
ToJSON a =>
ItemDescriptor (Maybe a) -> SerializedItemDescriptor
createSerializedItemDescriptor ItemDescriptor {$sel:value:ItemDescriptor :: forall a. ItemDescriptor a -> a
value = Maybe a
Nothing, Natural
version :: Natural
$sel:version:ItemDescriptor :: forall a. ItemDescriptor a -> Natural
version} = SerializedItemDescriptor {$sel:item:SerializedItemDescriptor :: Maybe ByteString
item = forall a. Maybe a
Nothing, Natural
version :: Natural
$sel:version:SerializedItemDescriptor :: Natural
version, $sel:deleted:SerializedItemDescriptor :: Bool
deleted = Bool
True}
createSerializedItemDescriptor ItemDescriptor {$sel:value:ItemDescriptor :: forall a. ItemDescriptor a -> a
value = Just a
item, Natural
version :: Natural
$sel:version:ItemDescriptor :: forall a. ItemDescriptor a -> Natural
version} = SerializedItemDescriptor {$sel:item:SerializedItemDescriptor :: Maybe ByteString
item = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode a
item, Natural
version :: Natural
$sel:version:SerializedItemDescriptor :: Natural
version, $sel:deleted:SerializedItemDescriptor :: Bool
deleted = Bool
False}

tryGetBackend :: (FromJSON a, HasField' "version" a Natural) => PersistentDataStore -> Text -> Text -> StoreResult (Maybe (ItemDescriptor (Maybe a)))
tryGetBackend :: forall a.
(FromJSON a, HasField' "version" a Natural) =>
PersistentDataStore
-> Text -> Text -> StoreResult (Maybe (ItemDescriptor (Maybe a)))
tryGetBackend PersistentDataStore
backend Text
namespace Text
key =
    ((PersistentDataStore
-> Text -> Text -> StoreResult (Maybe SerializedItemDescriptor)
persistentDataStoreGetFeature PersistentDataStore
backend) Text
namespace Text
key) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Text
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
err
        Right Maybe SerializedItemDescriptor
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
        Right (Just SerializedItemDescriptor
serializedItem) -> case forall a.
(FromJSON a, HasField' "version" a Natural) =>
SerializedItemDescriptor -> Either Text (ItemDescriptor (Maybe a))
serializedToItemDescriptor SerializedItemDescriptor
serializedItem of
            Left Text
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
err
            Right ItemDescriptor (Maybe a)
versioned -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ItemDescriptor (Maybe a)
versioned

getGeneric ::
    (FromJSON a, HasField' "version" a Natural) =>
    Store ->
    Text ->
    Text ->
    Lens' State (KeyMap (Expirable (CacheableItem a))) ->
    StoreResult (Maybe a)
getGeneric :: forall a.
(FromJSON a, HasField' "version" a Natural) =>
Store
-> Text
-> Text
-> Lens' State (KeyMap (Expirable (CacheableItem a)))
-> StoreResult (Maybe a)
getGeneric Store
store Text
namespace Text
key Lens' State (KeyMap (Expirable (CacheableItem a)))
lens = do
    State
state <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store
    case forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"backend" Store
store of
        Maybe PersistentDataStore
Nothing -> case forall v. Text -> KeyMap v -> Maybe v
lookupKey Text
key (State
state forall s a. s -> Getting a s a -> a
^. Lens' State (KeyMap (Expirable (CacheableItem a)))
lens) of
            Maybe (Expirable (CacheableItem a))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
            Just Expirable (CacheableItem a)
cacheItem -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value") forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" Expirable (CacheableItem a)
cacheItem)
        Just PersistentDataStore
backend -> do
            TimeSpec
now <- IO TimeSpec
getMonotonicTime
            case forall v. Text -> KeyMap v -> Maybe v
lookupKey Text
key (State
state forall s a. s -> Getting a s a -> a
^. Lens' State (KeyMap (Expirable (CacheableItem a)))
lens) of
                Maybe (Expirable (CacheableItem a))
Nothing -> PersistentDataStore -> TimeSpec -> StoreResult (Maybe a)
updateFromBackend PersistentDataStore
backend TimeSpec
now
                Just Expirable (CacheableItem a)
cacheItem ->
                    if forall a. Store -> TimeSpec -> Expirable a -> Bool
isExpired Store
store TimeSpec
now Expirable (CacheableItem a)
cacheItem
                        then PersistentDataStore -> TimeSpec -> StoreResult (Maybe a)
updateFromBackend PersistentDataStore
backend TimeSpec
now
                        else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value") forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" Expirable (CacheableItem a)
cacheItem)
  where
    updateFromBackend :: PersistentDataStore -> TimeSpec -> StoreResult (Maybe a)
updateFromBackend PersistentDataStore
backend TimeSpec
now =
        forall a.
(FromJSON a, HasField' "version" a Natural) =>
PersistentDataStore
-> Text -> Text -> StoreResult (Maybe (ItemDescriptor (Maybe a)))
tryGetBackend PersistentDataStore
backend Text
namespace Text
key forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left Text
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
err
            Right CacheableItem a
Nothing -> do
                forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store) forall a b. (a -> b) -> a -> b
$ \State
stateRef ->
                    (,()) forall a b. (a -> b) -> a -> b
$
                        State
stateRef
                            forall a b. a -> (a -> b) -> b
& Lens' State (KeyMap (Expirable (CacheableItem a)))
lens
                                forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
key (forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable forall a. Maybe a
Nothing Bool
False TimeSpec
now))
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
            Right (Just ItemDescriptor (Maybe a)
v) -> do
                forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store) forall a b. (a -> b) -> a -> b
$ \State
stateRef ->
                    (,()) forall a b. (a -> b) -> a -> b
$
                        State
stateRef
                            forall a b. a -> (a -> b) -> b
& Lens' State (KeyMap (Expirable (CacheableItem a)))
lens
                                forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
key (forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable (forall a. a -> Maybe a
Just ItemDescriptor (Maybe a)
v) Bool
False TimeSpec
now))
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" ItemDescriptor (Maybe a)
v

getFlag :: Store -> Text -> StoreResult (Maybe Flag)
getFlag :: Store -> Text -> StoreResultM IO (Maybe Flag)
getFlag Store
store Text
key = forall a.
(FromJSON a, HasField' "version" a Natural) =>
Store
-> Text
-> Text
-> Lens' State (KeyMap (Expirable (CacheableItem a)))
-> StoreResult (Maybe a)
getGeneric Store
store Text
"features" Text
key (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"features")

getSegment :: Store -> Text -> StoreResult (Maybe Segment)
getSegment :: Store -> Text -> StoreResultM IO (Maybe Segment)
getSegment Store
store Text
key = forall a.
(FromJSON a, HasField' "version" a Natural) =>
Store
-> Text
-> Text
-> Lens' State (KeyMap (Expirable (CacheableItem a)))
-> StoreResult (Maybe a)
getGeneric Store
store Text
"segments" Text
key (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"segments")

upsertGeneric ::
    (ToJSON a) =>
    Store ->
    Text ->
    Text ->
    ItemDescriptor (Maybe a) ->
    Lens' State (KeyMap (Expirable (CacheableItem a))) ->
    (Bool -> State -> State) ->
    StoreResult ()
upsertGeneric :: forall a.
ToJSON a =>
Store
-> Text
-> Text
-> ItemDescriptor (Maybe a)
-> Lens' State (KeyMap (Expirable (CacheableItem a)))
-> (Bool -> State -> State)
-> StoreResultM IO ()
upsertGeneric Store
store Text
namespace Text
key ItemDescriptor (Maybe a)
versioned Lens' State (KeyMap (Expirable (CacheableItem a)))
lens Bool -> State -> State
action = do
    case forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"backend" Store
store of
        Maybe PersistentDataStore
Nothing -> do
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store) forall a b. (a -> b) -> a -> b
$ \State
stateRef -> (,()) forall a b. (a -> b) -> a -> b
$ State -> State
upsertMemory State
stateRef
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
        Just PersistentDataStore
backend -> do
            Either Text Bool
result <- (PersistentDataStore
-> Text -> Text -> SerializedItemDescriptor -> StoreResultM IO Bool
persistentDataStoreUpsertFeature PersistentDataStore
backend) Text
namespace Text
key (forall a.
ToJSON a =>
ItemDescriptor (Maybe a) -> SerializedItemDescriptor
createSerializedItemDescriptor ItemDescriptor (Maybe a)
versioned)
            case Either Text Bool
result of
                Left Text
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
err
                Right Bool
updated ->
                    if Bool -> Bool
not Bool
updated
                        then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ())
                        else do
                            TimeSpec
now <- IO TimeSpec
getMonotonicTime
                            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store) forall a b. (a -> b) -> a -> b
$ \State
stateRef ->
                                (,()) forall a b. (a -> b) -> a -> b
$
                                    State
stateRef
                                        forall a b. a -> (a -> b) -> b
& Lens' State (KeyMap (Expirable (CacheableItem a)))
lens forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
key (forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable (forall a. a -> Maybe a
Just ItemDescriptor (Maybe a)
versioned) Bool
False TimeSpec
now))
                                        forall a b. a -> (a -> b) -> b
& Bool -> State -> State
action Bool
True
                            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
  where
    upsertMemory :: State -> State
upsertMemory State
state = case forall v. Text -> KeyMap v -> Maybe v
lookupKey Text
key (State
state forall s a. s -> Getting a s a -> a
^. Lens' State (KeyMap (Expirable (CacheableItem a)))
lens) of
        Maybe (Expirable (CacheableItem a))
Nothing -> State -> State
updateMemory State
state
        Just Expirable (CacheableItem a)
cacheItem -> case forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" Expirable (CacheableItem a)
cacheItem of
            CacheableItem a
Nothing -> State -> State
updateMemory State
state
            Just ItemDescriptor (Maybe a)
existing ->
                if (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"version" ItemDescriptor (Maybe a)
existing) forall a. Ord a => a -> a -> Bool
< forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"version" ItemDescriptor (Maybe a)
versioned
                    then State -> State
updateMemory State
state
                    else State
state
    updateMemory :: State -> State
updateMemory State
state =
        State
state
            forall a b. a -> (a -> b) -> b
& Lens' State (KeyMap (Expirable (CacheableItem a)))
lens forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
key (forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable (forall a. a -> Maybe a
Just ItemDescriptor (Maybe a)
versioned) Bool
False TimeSpec
0))
            forall a b. a -> (a -> b) -> b
& Bool -> State -> State
action Bool
False

upsertFlag :: Store -> Text -> ItemDescriptor (Maybe Flag) -> StoreResult ()
upsertFlag :: Store -> Text -> ItemDescriptor (Maybe Flag) -> StoreResultM IO ()
upsertFlag Store
store Text
key ItemDescriptor (Maybe Flag)
versioned = forall a.
ToJSON a =>
Store
-> Text
-> Text
-> ItemDescriptor (Maybe a)
-> Lens' State (KeyMap (Expirable (CacheableItem a)))
-> (Bool -> State -> State)
-> StoreResultM IO ()
upsertGeneric Store
store Text
"features" Text
key ItemDescriptor (Maybe Flag)
versioned (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"features") Bool -> State -> State
postAction
  where
    postAction :: Bool -> State -> State
postAction Bool
external State
state =
        if Bool
external
            then State
state forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"allFlags" forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"forceExpire" Bool
True)
            else State
state forall a b. a -> (a -> b) -> b
& (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"allFlags" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"value") forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyMap Flag -> KeyMap Flag
updateAllFlags
    updateAllFlags :: KeyMap Flag -> KeyMap Flag
updateAllFlags KeyMap Flag
allFlags = case forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" ItemDescriptor (Maybe Flag)
versioned of
        Maybe Flag
Nothing -> forall v. Text -> KeyMap v -> KeyMap v
deleteKey Text
key KeyMap Flag
allFlags
        Just Flag
flag -> forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
key Flag
flag KeyMap Flag
allFlags

upsertSegment :: Store -> Text -> ItemDescriptor (Maybe Segment) -> StoreResult ()
upsertSegment :: Store
-> Text -> ItemDescriptor (Maybe Segment) -> StoreResultM IO ()
upsertSegment Store
store Text
key ItemDescriptor (Maybe Segment)
versioned = forall a.
ToJSON a =>
Store
-> Text
-> Text
-> ItemDescriptor (Maybe a)
-> Lens' State (KeyMap (Expirable (CacheableItem a)))
-> (Bool -> State -> State)
-> StoreResultM IO ()
upsertGeneric Store
store Text
"segments" Text
key ItemDescriptor (Maybe Segment)
versioned (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"segments") forall {p} {p}. p -> p -> p
postAction
  where
    postAction :: p -> p -> p
postAction p
_ p
state = p
state

filterAndCacheFlags :: Store -> TimeSpec -> KeyMap SerializedItemDescriptor -> IO (KeyMap Flag)
filterAndCacheFlags :: Store
-> TimeSpec -> KeyMap SerializedItemDescriptor -> IO (KeyMap Flag)
filterAndCacheFlags Store
store TimeSpec
now KeyMap SerializedItemDescriptor
serializedMap = do
    let decoded :: KeyMap (ItemDescriptor (Maybe Flag))
decoded = forall v1 v2. (v1 -> Maybe v2) -> KeyMap v1 -> KeyMap v2
mapMaybeValues (forall a b. Either a b -> Maybe b
eitherToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(FromJSON a, HasField' "version" a Natural) =>
SerializedItemDescriptor -> Either Text (ItemDescriptor (Maybe a))
serializedToItemDescriptor) KeyMap SerializedItemDescriptor
serializedMap
        allFlags :: KeyMap Flag
allFlags = forall v1 v2. (v1 -> Maybe v2) -> KeyMap v1 -> KeyMap v2
mapMaybeValues (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value") KeyMap (ItemDescriptor (Maybe Flag))
decoded
    forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store) forall a b. (a -> b) -> a -> b
$ \State
state ->
        (,()) forall a b. (a -> b) -> a -> b
$
            forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"allFlags" (forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable KeyMap Flag
allFlags Bool
False TimeSpec
now) forall a b. (a -> b) -> a -> b
$
                forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"features" (forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues (\ItemDescriptor (Maybe Flag)
x -> forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable (forall a. a -> Maybe a
Just ItemDescriptor (Maybe Flag)
x) Bool
False TimeSpec
now) KeyMap (ItemDescriptor (Maybe Flag))
decoded) State
state
    forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMap Flag
allFlags

getAllFlags :: Store -> StoreResult (KeyMap Flag)
getAllFlags :: Store -> StoreResultM IO (KeyMap Flag)
getAllFlags Store
store = do
    State
state <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store
    let memoryFlags :: StoreResultM IO (KeyMap Flag)
memoryFlags = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"allFlags" State
state
    case forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"backend" Store
store of
        Maybe PersistentDataStore
Nothing -> StoreResultM IO (KeyMap Flag)
memoryFlags
        Just PersistentDataStore
backend -> do
            TimeSpec
now <- IO TimeSpec
getMonotonicTime
            if Bool -> Bool
not (forall a. Store -> TimeSpec -> Expirable a -> Bool
isExpired Store
store TimeSpec
now forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"allFlags" State
state)
                then StoreResultM IO (KeyMap Flag)
memoryFlags
                else do
                    Either Text (KeyMap SerializedItemDescriptor)
result <- (PersistentDataStore
-> Text -> StoreResult (KeyMap SerializedItemDescriptor)
persistentDataStoreAllFeatures PersistentDataStore
backend) Text
"features"
                    case Either Text (KeyMap SerializedItemDescriptor)
result of
                        Left Text
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left Text
err)
                        Right KeyMap SerializedItemDescriptor
serializedMap -> do
                            KeyMap Flag
filtered <- Store
-> TimeSpec -> KeyMap SerializedItemDescriptor -> IO (KeyMap Flag)
filterAndCacheFlags Store
store TimeSpec
now KeyMap SerializedItemDescriptor
serializedMap
                            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right KeyMap Flag
filtered)

isInitialized :: Store -> StoreResult Bool
isInitialized :: Store -> StoreResultM IO Bool
isInitialized Store
store = do
    State
state <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store
    let initialized :: Expirable Bool
initialized = forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"initialized" State
state
    if forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" Expirable Bool
initialized
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Bool
True
        else case forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"backend" Store
store of
            Maybe PersistentDataStore
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Bool
False
            Just PersistentDataStore
backend -> do
                TimeSpec
now <- IO TimeSpec
getMonotonicTime
                if forall a. Store -> TimeSpec -> Expirable a -> Bool
isExpired Store
store TimeSpec
now Expirable Bool
initialized
                    then do
                        Either Text Bool
result <- PersistentDataStore -> StoreResultM IO Bool
persistentDataStoreIsInitialized PersistentDataStore
backend
                        case Either Text Bool
result of
                            Left Text
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
err
                            Right Bool
i -> do
                                forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"state" Store
store) forall a b. (a -> b) -> a -> b
$ \State
stateRef ->
                                    (,()) forall a b. (a -> b) -> a -> b
$
                                        forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"initialized" (forall a. a -> Bool -> TimeSpec -> Expirable a
Expirable Bool
i Bool
False TimeSpec
now) State
stateRef
                                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Bool
i
                    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Bool
False