module LaunchDarkly.Server.Store.Redis.Internal
    ( RedisStoreConfig
    , makeRedisStoreConfig
    , redisConfigSetNamespace
    , makeRedisStore
    ) where

import Control.Exception (throwIO)
import Control.Monad (forM_, void)
import Control.Monad.Catch (Exception, Handler (..), catches)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.Functor ((<&>))
import Data.Generics.Product (getField)
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Typeable (Typeable)
import Database.Redis
    ( Connection
    , ConnectionLostException
    , Redis
    , Reply
    , TxResult (..)
    , del
    , get
    , hget
    , hgetall
    , hset
    , multiExec
    , runRedis
    , set
    , watch
    )

import LaunchDarkly.AesonCompat (KeyMap, fromList, mapValues, objectKeys, toList)
import LaunchDarkly.Server.Store (PersistentDataStore (..), SerializedItemDescriptor (..), StoreResult, byteStringToVersionedData, serializeWithPlaceholder)

-- | Opaque type used to configure the Redis store integration.
data RedisStoreConfig = RedisStoreConfig
    { RedisStoreConfig -> Text
namespace :: Text
    , RedisStoreConfig -> Connection
connection :: Connection
    }

-- | Create a default config from a given connection pool.
makeRedisStoreConfig :: Connection -> RedisStoreConfig
makeRedisStoreConfig :: Connection -> RedisStoreConfig
makeRedisStoreConfig Connection
con =
    RedisStoreConfig
        { namespace :: Text
namespace = Text
"launchdarkly"
        , connection :: Connection
connection = Connection
con
        }

-- |
-- Configure the Redis key prefix. All keys are prefixed by default before
-- being inserted into Redis. The default prefix is "launchdarkly".
redisConfigSetNamespace :: Text -> RedisStoreConfig -> RedisStoreConfig
redisConfigSetNamespace :: Text -> RedisStoreConfig -> RedisStoreConfig
redisConfigSetNamespace Text
namespace' RedisStoreConfig
config = RedisStoreConfig
config {namespace :: Text
namespace = Text
namespace'}

-- |
-- Construct a `PersistentDataStore` that can then be used during SDK
-- configuration.
makeRedisStore :: RedisStoreConfig -> IO PersistentDataStore
makeRedisStore :: RedisStoreConfig -> IO PersistentDataStore
makeRedisStore RedisStoreConfig
config =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        PersistentDataStore
            { $sel:persistentDataStoreUpsertFeature:PersistentDataStore :: Text -> Text -> SerializedItemDescriptor -> StoreResult Bool
persistentDataStoreUpsertFeature = RedisStoreConfig
-> Text -> Text -> SerializedItemDescriptor -> StoreResult Bool
redisUpsert RedisStoreConfig
config
            , $sel:persistentDataStoreGetFeature:PersistentDataStore :: Text -> Text -> StoreResult (Maybe SerializedItemDescriptor)
persistentDataStoreGetFeature = RedisStoreConfig
-> Text -> Text -> StoreResult (Maybe SerializedItemDescriptor)
redisGetFeature RedisStoreConfig
config
            , $sel:persistentDataStoreInitialize:PersistentDataStore :: KeyMap (KeyMap SerializedItemDescriptor) -> StoreResult ()
persistentDataStoreInitialize = RedisStoreConfig
-> KeyMap (KeyMap SerializedItemDescriptor) -> StoreResult ()
redisInitialize RedisStoreConfig
config
            , $sel:persistentDataStoreIsInitialized:PersistentDataStore :: StoreResult Bool
persistentDataStoreIsInitialized = RedisStoreConfig -> StoreResult Bool
redisIsInitialized RedisStoreConfig
config
            , $sel:persistentDataStoreAllFeatures:PersistentDataStore :: Text -> StoreResult (KeyMap SerializedItemDescriptor)
persistentDataStoreAllFeatures = RedisStoreConfig
-> Text -> StoreResult (KeyMap SerializedItemDescriptor)
redisGetAll RedisStoreConfig
config
            }

newtype RedisError = RedisError Text deriving (Typeable, Int -> RedisError -> ShowS
[RedisError] -> ShowS
RedisError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedisError] -> ShowS
$cshowList :: [RedisError] -> ShowS
show :: RedisError -> String
$cshow :: RedisError -> String
showsPrec :: Int -> RedisError -> ShowS
$cshowsPrec :: Int -> RedisError -> ShowS
Show, Show RedisError
Typeable RedisError
SomeException -> Maybe RedisError
RedisError -> String
RedisError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: RedisError -> String
$cdisplayException :: RedisError -> String
fromException :: SomeException -> Maybe RedisError
$cfromException :: SomeException -> Maybe RedisError
toException :: RedisError -> SomeException
$ctoException :: RedisError -> SomeException
Exception)

makeKey :: RedisStoreConfig -> Text -> ByteString
makeKey :: RedisStoreConfig -> Text -> ByteString
makeKey RedisStoreConfig
config Text
key = Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [RedisStoreConfig -> Text
namespace RedisStoreConfig
config, Text
":", Text
key]

exceptOnReply :: (MonadIO m) => Either Reply a -> m a
exceptOnReply :: forall (m :: * -> *) a. MonadIO m => Either Reply a -> m a
exceptOnReply = \case
    Left Reply
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> RedisError
RedisError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Reply
err
    Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

run :: RedisStoreConfig -> Redis a -> StoreResult a
run :: forall a. RedisStoreConfig -> Redis a -> StoreResult a
run RedisStoreConfig
config Redis a
action =
    forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m a
catches
        (forall a. Connection -> Redis a -> IO a
runRedis (RedisStoreConfig -> Connection
connection RedisStoreConfig
config) Redis a
action forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (f :: * -> *) a. Applicative f => a -> f a
pure)
        [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \(ConnectionLostException
e :: ConnectionLostException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ConnectionLostException
e
        , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \(RedisError 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
        ]

createSerializedItemDescriptor :: ByteString -> SerializedItemDescriptor
createSerializedItemDescriptor :: ByteString -> SerializedItemDescriptor
createSerializedItemDescriptor ByteString
byteString = Maybe ByteString -> Natural -> Bool -> SerializedItemDescriptor
SerializedItemDescriptor (forall a. a -> Maybe a
Just ByteString
byteString) Natural
0 Bool
False

redisInitialize :: RedisStoreConfig -> KeyMap (KeyMap SerializedItemDescriptor) -> StoreResult ()
redisInitialize :: RedisStoreConfig
-> KeyMap (KeyMap SerializedItemDescriptor) -> StoreResult ()
redisInitialize RedisStoreConfig
config KeyMap (KeyMap SerializedItemDescriptor)
values = forall a. RedisStoreConfig -> Redis a -> StoreResult a
run RedisStoreConfig
config forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[ByteString] -> m (f Integer)
del (forall a b. (a -> b) -> [a] -> [b]
map (RedisStoreConfig -> Text -> ByteString
makeKey RedisStoreConfig
config) forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [Text]
objectKeys KeyMap (KeyMap SerializedItemDescriptor)
values) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => Either Reply a -> m a
exceptOnReply
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall v. KeyMap v -> [(Text, v)]
toList KeyMap (KeyMap SerializedItemDescriptor)
values) forall a b. (a -> b) -> a -> b
$ \(Text
kind, KeyMap SerializedItemDescriptor
features) -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall v. KeyMap v -> [(Text, v)]
toList KeyMap SerializedItemDescriptor
features) forall a b. (a -> b) -> a -> b
$ \(Text
key, SerializedItemDescriptor
feature) ->
        forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> ByteString -> ByteString -> m (f Integer)
hset (RedisStoreConfig -> Text -> ByteString
makeKey RedisStoreConfig
config Text
kind) (Text -> ByteString
encodeUtf8 Text
key) (SerializedItemDescriptor -> ByteString
serializeWithPlaceholder SerializedItemDescriptor
feature) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => Either Reply a -> m a
exceptOnReply
    forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> ByteString -> m (f Status)
set (RedisStoreConfig -> Text -> ByteString
makeKey RedisStoreConfig
config Text
"$inited") ByteString
"" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => Either Reply a -> m a
exceptOnReply

redisUpsert :: RedisStoreConfig -> Text -> Text -> SerializedItemDescriptor -> StoreResult Bool
redisUpsert :: RedisStoreConfig
-> Text -> Text -> SerializedItemDescriptor -> StoreResult Bool
redisUpsert = IO ()
-> RedisStoreConfig
-> Text
-> Text
-> SerializedItemDescriptor
-> StoreResult Bool
redisUpsertInternal (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

redisUpsertInternal :: IO () -> RedisStoreConfig -> Text -> Text -> SerializedItemDescriptor -> StoreResult Bool
redisUpsertInternal :: IO ()
-> RedisStoreConfig
-> Text
-> Text
-> SerializedItemDescriptor
-> StoreResult Bool
redisUpsertInternal IO ()
hook RedisStoreConfig
config Text
kind Text
key SerializedItemDescriptor
opaque = forall a. RedisStoreConfig -> Redis a -> StoreResult a
run RedisStoreConfig
config Redis Bool
tryUpsert
  where
    tryUpsert :: Redis Bool
tryUpsert =
        [ByteString] -> Redis (Either Reply Status)
watch [ByteString
space]
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => Either Reply a -> m a
exceptOnReply
            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> ByteString -> m (f (Maybe ByteString))
hget ByteString
space (Text -> ByteString
encodeUtf8 Text
key)
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => Either Reply a -> m a
exceptOnReply
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe ByteString
x ->
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
hook forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> case Maybe ByteString
x of
                    Maybe ByteString
Nothing -> Redis Bool
doInsert
                    (Just ByteString
byteString) -> case ByteString -> Maybe VersionedData
byteStringToVersionedData ByteString
byteString of
                        Maybe VersionedData
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                        Just VersionedData
decodedVersion ->
                            if forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"version" VersionedData
decodedVersion forall a. Ord a => a -> a -> Bool
>= forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"version" SerializedItemDescriptor
opaque
                                then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                                else Redis Bool
doInsert
    space :: ByteString
space = RedisStoreConfig -> Text -> ByteString
makeKey RedisStoreConfig
config Text
kind
    doInsert :: Redis Bool
doInsert =
        forall a. RedisTx (Queued a) -> Redis (TxResult a)
multiExec (forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> ByteString -> ByteString -> m (f Integer)
hset ByteString
space (Text -> ByteString
encodeUtf8 Text
key) (SerializedItemDescriptor -> ByteString
serializeWithPlaceholder SerializedItemDescriptor
opaque)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            TxSuccess Integer
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
            TxError String
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> RedisError
RedisError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
err
            TxResult Integer
TxAborted -> Redis Bool
tryUpsert

redisGetFeature :: RedisStoreConfig -> Text -> Text -> StoreResult (Maybe SerializedItemDescriptor)
redisGetFeature :: RedisStoreConfig
-> Text -> Text -> StoreResult (Maybe SerializedItemDescriptor)
redisGetFeature RedisStoreConfig
config Text
kind Text
key =
    forall a. RedisStoreConfig -> Redis a -> StoreResult a
run RedisStoreConfig
config forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> ByteString -> m (f (Maybe ByteString))
hget (RedisStoreConfig -> Text -> ByteString
makeKey RedisStoreConfig
config Text
kind) (Text -> ByteString
encodeUtf8 Text
key)
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => Either Reply a -> m a
exceptOnReply
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe ByteString
result -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> SerializedItemDescriptor
createSerializedItemDescriptor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
result

redisIsInitialized :: RedisStoreConfig -> StoreResult Bool
redisIsInitialized :: RedisStoreConfig -> StoreResult Bool
redisIsInitialized RedisStoreConfig
config =
    forall a. RedisStoreConfig -> Redis a -> StoreResult a
run RedisStoreConfig
config forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f (Maybe ByteString))
get (RedisStoreConfig -> Text -> ByteString
makeKey RedisStoreConfig
config Text
"$inited") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => Either Reply a -> m a
exceptOnReply) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. Maybe a -> Bool
isJust

redisGetAll :: RedisStoreConfig -> Text -> StoreResult (KeyMap SerializedItemDescriptor)
redisGetAll :: RedisStoreConfig
-> Text -> StoreResult (KeyMap SerializedItemDescriptor)
redisGetAll RedisStoreConfig
config Text
kind =
    forall a. RedisStoreConfig -> Redis a -> StoreResult a
run RedisStoreConfig
config forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f [(ByteString, ByteString)])
hgetall (RedisStoreConfig -> Text -> ByteString
makeKey RedisStoreConfig
config Text
kind) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => Either Reply a -> m a
exceptOnReply) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues ByteString -> SerializedItemDescriptor
createSerializedItemDescriptor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. [(Text, v)] -> KeyMap v
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ByteString -> Text
decodeUtf8))