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 <- IO (MVar Features) -> m (MVar Features)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar Features)
forall a. IO (MVar a)
newEmptyMVar
MVar [(Text, Bool)]
metrics <- IO (MVar [(Text, Bool)]) -> m (MVar [(Text, Bool)])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar [(Text, Bool)]) -> m (MVar [(Text, Bool)]))
-> IO (MVar [(Text, Bool)]) -> m (MVar [(Text, Bool)])
forall a b. (a -> b) -> a -> b
$ [(Text, Bool)] -> IO (MVar [(Text, Bool)])
forall a. a -> IO (MVar a)
newMVar [(Text, Bool)]
forall a. Monoid a => a
mempty
MVar UTCTime
metricsBucketStart <- IO (MVar UTCTime) -> m (MVar UTCTime)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar UTCTime) -> m (MVar UTCTime))
-> IO (MVar UTCTime) -> m (MVar UTCTime)
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime IO UTCTime -> (UTCTime -> IO (MVar UTCTime)) -> IO (MVar UTCTime)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UTCTime -> IO (MVar UTCTime)
forall a. a -> IO (MVar a)
newMVar
Manager
manager <- m Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
let clientEnv :: ClientEnv
clientEnv = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
serverUrl
UnleashConfig -> m UnleashConfig
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnleashConfig -> m UnleashConfig)
-> UnleashConfig -> m UnleashConfig
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 <- (r -> UnleashConfig) -> m UnleashConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> UnleashConfig
forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
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
}
Either ClientError NoContent -> Either ClientError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either ClientError NoContent -> Either ClientError ())
-> m (Either ClientError NoContent) -> m (Either ClientError ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientEnv
-> Maybe Text
-> RegisterPayload
-> m (Either ClientError NoContent)
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 <- (r -> UnleashConfig) -> m UnleashConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> UnleashConfig
forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
Either ClientError Features
eitherFeatures <- ClientEnv -> Maybe Text -> m (Either ClientError Features)
forall (m :: * -> *).
MonadIO m =>
ClientEnv -> Maybe Text -> m (Either ClientError Features)
getAllClientFeatures UnleashConfig
config.httpClientEnvironment UnleashConfig
config.apiKey
(ClientError -> m ())
-> (Features -> m ()) -> Either ClientError Features -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m () -> ClientError -> m ()
forall a b. a -> b -> a
const (m () -> ClientError -> m ()) -> m () -> ClientError -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (MVar Features -> Features -> m ()
forall {m :: * -> *} {a}. MonadIO m => MVar a -> a -> m ()
updateState UnleashConfig
config.state) Either ClientError Features
eitherFeatures
Either ClientError () -> m (Either ClientError ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ClientError () -> m (Either ClientError ()))
-> (Either ClientError Features -> Either ClientError ())
-> Either ClientError Features
-> m (Either ClientError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ClientError Features -> Either ClientError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either ClientError Features -> m (Either ClientError ()))
-> Either ClientError Features -> m (Either ClientError ())
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 <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar a
state a
value
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO a -> IO ()) -> IO a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isUpdated (IO () -> IO ()) -> (IO a -> IO ()) -> IO a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> m ()) -> IO a -> m ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO a
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 <- (r -> UnleashConfig) -> m UnleashConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> UnleashConfig
forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
UTCTime
lastBucketStart <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> m UTCTime) -> IO UTCTime -> m UTCTime
forall a b. (a -> b) -> a -> b
$ MVar UTCTime -> UTCTime -> IO UTCTime
forall a. MVar a -> a -> IO a
swapMVar UnleashConfig
config.metricsBucketStart UTCTime
now
[(Text, Bool)]
bucket <- IO [(Text, Bool)] -> m [(Text, Bool)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Bool)] -> m [(Text, Bool)])
-> IO [(Text, Bool)] -> m [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ MVar [(Text, Bool)] -> [(Text, Bool)] -> IO [(Text, Bool)]
forall a. MVar a -> a -> IO a
swapMVar UnleashConfig
config.metrics [(Text, Bool)]
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
}
Either ClientError NoContent -> Either ClientError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either ClientError NoContent -> Either ClientError ())
-> m (Either ClientError NoContent) -> m (Either ClientError ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientEnv
-> Maybe Text -> MetricsPayload -> m (Either ClientError NoContent)
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 <- (r -> UnleashConfig) -> m UnleashConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> UnleashConfig
forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
Features
state <- IO Features -> m Features
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Features -> m Features)
-> (MVar Features -> IO Features) -> MVar Features -> m Features
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Features -> IO Features
forall a. MVar a -> IO a
readMVar (MVar Features -> m Features) -> MVar Features -> m Features
forall a b. (a -> b) -> a -> b
$ UnleashConfig
config.state
Bool
enabled <- Features -> Text -> Context -> m Bool
forall (m :: * -> *).
MonadIO m =>
Features -> Text -> Context -> m Bool
featureIsEnabled Features
state Text
feature Context
context
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar [(Text, Bool)]
-> ([(Text, Bool)] -> IO [(Text, Bool)]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ UnleashConfig
config.metrics (\[(Text, Bool)]
info -> [(Text, Bool)] -> IO [(Text, Bool)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, Bool)] -> IO [(Text, Bool)])
-> [(Text, Bool)] -> IO [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ (Text
feature, Bool
enabled) (Text, Bool) -> [(Text, Bool)] -> [(Text, Bool)]
forall a. a -> [a] -> [a]
: [(Text, Bool)]
info)
Bool -> m Bool
forall a. a -> m a
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 <- (r -> UnleashConfig) -> m UnleashConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> UnleashConfig
forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
Maybe Features
maybeState <- IO (Maybe Features) -> m (Maybe Features)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Features) -> m (Maybe Features))
-> (MVar Features -> IO (Maybe Features))
-> MVar Features
-> m (Maybe Features)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Features -> IO (Maybe Features)
forall a. MVar a -> IO (Maybe a)
tryReadMVar (MVar Features -> m (Maybe Features))
-> MVar Features -> m (Maybe Features)
forall a b. (a -> b) -> a -> b
$ UnleashConfig
config.state
case Maybe Features
maybeState of
Just Features
state -> do
Bool
enabled <- Features -> Text -> Context -> m Bool
forall (m :: * -> *).
MonadIO m =>
Features -> Text -> Context -> m Bool
featureIsEnabled Features
state Text
feature Context
context
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar [(Text, Bool)]
-> ([(Text, Bool)] -> IO [(Text, Bool)]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ UnleashConfig
config.metrics (\[(Text, Bool)]
info -> [(Text, Bool)] -> IO [(Text, Bool)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, Bool)] -> IO [(Text, Bool)])
-> [(Text, Bool)] -> IO [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ (Text
feature, Bool
enabled) (Text, Bool) -> [(Text, Bool)] -> [(Text, Bool)]
forall a. a -> [a] -> [a]
: [(Text, Bool)]
info)
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
enabled
Maybe Features
Nothing -> Bool -> m Bool
forall a. a -> m a
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 <- (r -> UnleashConfig) -> m UnleashConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> UnleashConfig
forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
Features
state <- IO Features -> m Features
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Features -> m Features)
-> (MVar Features -> IO Features) -> MVar Features -> m Features
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Features -> IO Features
forall a. MVar a -> IO a
readMVar (MVar Features -> m Features) -> MVar Features -> m Features
forall a b. (a -> b) -> a -> b
$ UnleashConfig
config.state
Features -> Text -> Context -> m VariantResponse
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 <- (r -> UnleashConfig) -> m UnleashConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> UnleashConfig
forall r. HasUnleash r => r -> UnleashConfig
getUnleashConfig
Maybe Features
maybeState <- IO (Maybe Features) -> m (Maybe Features)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Features) -> m (Maybe Features))
-> (MVar Features -> IO (Maybe Features))
-> MVar Features
-> m (Maybe Features)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Features -> IO (Maybe Features)
forall a. MVar a -> IO (Maybe a)
tryReadMVar (MVar Features -> m (Maybe Features))
-> MVar Features -> m (Maybe Features)
forall a b. (a -> b) -> a -> b
$ UnleashConfig
config.state
case Maybe Features
maybeState of
Just Features
state -> do
Features -> Text -> Context -> m VariantResponse
forall (m :: * -> *).
MonadIO m =>
Features -> Text -> Context -> m VariantResponse
featureGetVariant Features
state Text
feature Context
context
Maybe Features
Nothing -> VariantResponse -> m VariantResponse
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VariantResponse
emptyVariantResponse