module Unleash.Client (
makeUnleashConfig,
UnleashConfig (..),
HasUnleash (..),
registerClient,
pollToggles,
pushMetrics,
isEnabled,
tryIsEnabled,
getVariant,
tryGetVariant,
Context (..),
emptyContext,
VariantResponse (..),
) where
import Control.Concurrent.MVar
import Control.Monad (unless, void)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Reader (MonadReader, asks)
import Data.Text (Text)
import Data.Time (UTCTime, getCurrentTime)
import Network.HTTP.Client.TLS (newTlsManager)
import Servant.Client (BaseUrl, ClientEnv, ClientError, mkClientEnv)
import Unleash (Context (..), Features, MetricsPayload (..), RegisterPayload (..), VariantResponse (..), emptyContext, emptyVariantResponse, featureGetVariant, featureIsEnabled)
import Unleash.Internal.HttpClient (getAllClientFeatures, register, sendMetrics)
makeUnleashConfig ::
MonadIO m =>
Text ->
Text ->
BaseUrl ->
Maybe Text ->
m UnleashConfig
makeUnleashConfig :: forall (m :: * -> *).
MonadIO m =>
Text -> Text -> BaseUrl -> Maybe Text -> m UnleashConfig
makeUnleashConfig Text
applicationName Text
instanceId BaseUrl
serverUrl Maybe Text
apiKey = do
MVar Features
state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (MVar a)
newEmptyMVar
MVar [(Text, Bool)]
metrics <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar forall a. Monoid a => a
mempty
MVar UTCTime
metricsBucketStart <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (MVar a)
newMVar
Manager
manager <- forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
let clientEnv :: ClientEnv
clientEnv = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
serverUrl
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
UnleashConfig
{ $sel:applicationName:UnleashConfig :: Text
applicationName = Text
applicationName,
$sel:instanceId:UnleashConfig :: Text
instanceId = Text
instanceId,
$sel:state:UnleashConfig :: MVar Features
state = MVar Features
state,
$sel:statePollIntervalInSeconds:UnleashConfig :: Int
statePollIntervalInSeconds = Int
4,
$sel:metrics:UnleashConfig :: MVar [(Text, Bool)]
metrics = MVar [(Text, Bool)]
metrics,
$sel:metricsBucketStart:UnleashConfig :: MVar UTCTime
metricsBucketStart = MVar UTCTime
metricsBucketStart,
$sel:metricsPushIntervalInSeconds:UnleashConfig :: Int
metricsPushIntervalInSeconds = Int
8,
$sel:apiKey:UnleashConfig :: Maybe Text
apiKey = Maybe Text
apiKey,
$sel:httpClientEnvironment:UnleashConfig :: ClientEnv
httpClientEnvironment = ClientEnv
clientEnv
}
data UnleashConfig = UnleashConfig
{
UnleashConfig -> Text
applicationName :: Text,
UnleashConfig -> Text
instanceId :: Text,
UnleashConfig -> MVar Features
state :: MVar Features,
UnleashConfig -> Int
statePollIntervalInSeconds :: Int,
UnleashConfig -> MVar [(Text, Bool)]
metrics :: MVar [(Text, Bool)],
UnleashConfig -> MVar UTCTime
metricsBucketStart :: MVar UTCTime,
UnleashConfig -> Int
metricsPushIntervalInSeconds :: Int,
UnleashConfig -> Maybe Text
apiKey :: Maybe Text,
UnleashConfig -> ClientEnv
httpClientEnvironment :: ClientEnv
}
class HasUnleash r where
getUnleashConfig :: r -> UnleashConfig
registerClient :: (HasUnleash r, MonadReader r m, MonadIO m) => m (Either ClientError ())
registerClient :: forall r (m :: * -> *).
(HasUnleash r, MonadReader r m, MonadIO m) =>
m (Either ClientError ())
registerClient = do
UnleashConfig
config <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let registrationPayload :: RegisterPayload
registrationPayload :: RegisterPayload
registrationPayload =
RegisterPayload
{ $sel:appName:RegisterPayload :: Text
appName = UnleashConfig
config.applicationName,
$sel:instanceId:RegisterPayload :: Text
instanceId = UnleashConfig
config.instanceId,
$sel:started:RegisterPayload :: UTCTime
started = UTCTime
now,
$sel:intervalSeconds:RegisterPayload :: Int
intervalSeconds = UnleashConfig
config.metricsPushIntervalInSeconds
}
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
ClientEnv
-> Maybe Text
-> RegisterPayload
-> m (Either ClientError NoContent)
register UnleashConfig
config.httpClientEnvironment UnleashConfig
config.apiKey RegisterPayload
registrationPayload
pollToggles :: (HasUnleash r, MonadReader r m, MonadIO m) => m (Either ClientError ())
pollToggles :: forall r (m :: * -> *).
(HasUnleash r, MonadReader r m, MonadIO m) =>
m (Either ClientError ())
pollToggles = do
UnleashConfig
config <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
Either ClientError Features
eitherFeatures <- forall (m :: * -> *).
MonadIO m =>
ClientEnv -> Maybe Text -> m (Either ClientError Features)
getAllClientFeatures UnleashConfig
config.httpClientEnvironment UnleashConfig
config.apiKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall {m :: * -> *} {a}. MonadIO m => MVar a -> a -> m ()
updateState UnleashConfig
config.state) Either ClientError Features
eitherFeatures
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Either ClientError Features
eitherFeatures
where
updateState :: MVar a -> a -> m ()
updateState MVar a
state a
value = do
Bool
isUpdated <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
tryPutMVar MVar a
state a
value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isUpdated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO a
swapMVar MVar a
state a
value
pushMetrics :: (HasUnleash r, MonadReader r m, MonadIO m) => m (Either ClientError ())
pushMetrics :: forall r (m :: * -> *).
(HasUnleash r, MonadReader r m, MonadIO m) =>
m (Either ClientError ())
pushMetrics = do
UnleashConfig
config <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
UTCTime
lastBucketStart <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO a
swapMVar UnleashConfig
config.metricsBucketStart UTCTime
now
[(Text, Bool)]
bucket <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO a
swapMVar UnleashConfig
config.metrics forall a. Monoid a => a
mempty
let metricsPayload :: MetricsPayload
metricsPayload =
MetricsPayload
{ $sel:appName:MetricsPayload :: Text
appName = UnleashConfig
config.applicationName,
$sel:instanceId:MetricsPayload :: Text
instanceId = UnleashConfig
config.instanceId,
$sel:start:MetricsPayload :: UTCTime
start = UTCTime
lastBucketStart,
$sel:stop:MetricsPayload :: UTCTime
stop = UTCTime
now,
$sel:toggles:MetricsPayload :: [(Text, Bool)]
toggles = [(Text, Bool)]
bucket
}
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
ClientEnv
-> Maybe Text -> MetricsPayload -> m (Either ClientError NoContent)
sendMetrics UnleashConfig
config.httpClientEnvironment UnleashConfig
config.apiKey MetricsPayload
metricsPayload
isEnabled ::
(HasUnleash r, MonadReader r m, MonadIO m) =>
Text ->
Context ->
m Bool
isEnabled :: forall r (m :: * -> *).
(HasUnleash r, MonadReader r m, MonadIO m) =>
Text -> Context -> m Bool
isEnabled Text
feature Context
context = do
UnleashConfig
config <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
Features
state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO a
readMVar forall a b. (a -> b) -> a -> b
$ UnleashConfig
config.state
Bool
enabled <- forall (m :: * -> *).
MonadIO m =>
Features -> Text -> Context -> m Bool
featureIsEnabled Features
state Text
feature Context
context
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ UnleashConfig
config.metrics (\[(Text, Bool)]
info -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Text
feature, Bool
enabled) forall a. a -> [a] -> [a]
: [(Text, Bool)]
info)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
enabled
tryIsEnabled ::
(HasUnleash r, MonadReader r m, MonadIO m) =>
Text ->
Context ->
m Bool
tryIsEnabled :: forall r (m :: * -> *).
(HasUnleash r, MonadReader r m, MonadIO m) =>
Text -> Context -> m Bool
tryIsEnabled Text
feature Context
context = do
UnleashConfig
config <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
Maybe Features
maybeState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO (Maybe a)
tryReadMVar forall a b. (a -> b) -> a -> b
$ UnleashConfig
config.state
case Maybe Features
maybeState of
Just Features
state -> do
Bool
enabled <- forall (m :: * -> *).
MonadIO m =>
Features -> Text -> Context -> m Bool
featureIsEnabled Features
state Text
feature Context
context
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ UnleashConfig
config.metrics (\[(Text, Bool)]
info -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Text
feature, Bool
enabled) forall a. a -> [a] -> [a]
: [(Text, Bool)]
info)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
enabled
Maybe Features
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
getVariant ::
(HasUnleash r, MonadReader r m, MonadIO m) =>
Text ->
Context ->
m VariantResponse
getVariant :: forall r (m :: * -> *).
(HasUnleash r, MonadReader r m, MonadIO m) =>
Text -> Context -> m VariantResponse
getVariant Text
feature Context
context = do
UnleashConfig
config <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
Features
state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO a
readMVar forall a b. (a -> b) -> a -> b
$ UnleashConfig
config.state
forall (m :: * -> *).
MonadIO m =>
Features -> Text -> Context -> m VariantResponse
featureGetVariant Features
state Text
feature Context
context
tryGetVariant ::
(HasUnleash r, MonadReader r m, MonadIO m) =>
Text ->
Context ->
m VariantResponse
tryGetVariant :: forall r (m :: * -> *).
(HasUnleash r, MonadReader r m, MonadIO m) =>
Text -> Context -> m VariantResponse
tryGetVariant Text
feature Context
context = do
UnleashConfig
config <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
Maybe Features
maybeState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO (Maybe a)
tryReadMVar forall a b. (a -> b) -> a -> b
$ UnleashConfig
config.state
case Maybe Features
maybeState of
Just Features
state -> do
forall (m :: * -> *).
MonadIO m =>
Features -> Text -> Context -> m VariantResponse
featureGetVariant Features
state Text
feature Context
context
Maybe Features
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure VariantResponse
emptyVariantResponse