Support custom strategies (#12)

flake.nix

@@ -7,11 +7,25 @@
     };
     flake-utils.url = "github:numtide/flake-utils";
     nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
+    unleash-client-haskell-core.url =
+      "github:finn-no/unleash-client-haskell-core?ref=81e5f7e7d38abbcffe51c2578e20fe39b28e256e";
   };
-  outputs = { self, nixpkgs, flake-compat, flake-utils }:
+  outputs = { self, nixpkgs, flake-compat, flake-utils, unleash-client-haskell-core }:
     flake-utils.lib.eachDefaultSystem (system:
       let
-        pkgs = import nixpkgs { inherit system; };
+        pkgs = import nixpkgs {
+          inherit system;
+          overlays = [
+            (self: super: {
+              haskellPackages = super.haskellPackages.override {
+                overrides = self: super: {
+                  unleash-client-haskell-core =
+                    pkgs.haskell.lib.dontCheck unleash-client-haskell-core.defaultPackage.${system};
+                };
+              };
+            })
+          ];
+        };
         unleash-client-haskell = pkgs.haskellPackages.callCabal2nix "unleash-client-haskell" ./. { };
       in {
         defaultPackage = unleash-client-haskell;

src/Unleash/Client.hs

@@ -13,7 +13,9 @@ module Unleash.Client (
     UnleashConfig (..),
     HasUnleash (..),
     registerClient,
+    registerClientWithCustomStrategies,
     pollToggles,
+    pollTogglesWithCustomStrategies,
     pushMetrics,
     isEnabled,
     tryIsEnabled,
@@ -22,6 +24,10 @@ module Unleash.Client (
     -- Re-exports
     Context (..),
     emptyContext,
+    FeatureToggleName,
+    Strategy (..),
+    StrategyEvaluator,
+    SupportedStrategies,
     VariantResponse (..),
 ) where
 
@@ -33,7 +39,23 @@ 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 (
+    Context (..),
+    FeatureToggleName,
+    Features,
+    MetricsPayload (..),
+    RegisterPayload (..),
+    Strategy (..),
+    StrategyEvaluator,
+    SupportedStrategies,
+    VariantResponse (..),
+    defaultStrategyEvaluator,
+    defaultSupportedStrategies,
+    emptyContext,
+    emptyVariantResponse,
+    featureGetVariant,
+    featureIsEnabled,
+ )
 import Unleash.Internal.HttpClient (getAllClientFeatures, register, sendMetrics)
 
 -- | Smart constructor for Unleash client configuration. Initializes the mutable variables properly.
@@ -96,31 +118,48 @@ class HasUnleash r where
 
 -- | Register client for the Unleash server. Call this on application startup before calling the state poller and metrics pusher functions.
 registerClient :: (HasUnleash r, MonadReader r m, MonadIO m) => m (Either ClientError ())
-registerClient = do
+registerClient = registerClientWithCustomStrategies defaultSupportedStrategies
+
+-- | Register client for the Unleash server. Custom strategies are added to default strategies. Call this on application startup before calling the state poller and metrics pusher functions.
+registerClientWithCustomStrategies :: (HasUnleash r, MonadReader r m, MonadIO m) => SupportedStrategies -> m (Either ClientError ())
+registerClientWithCustomStrategies customSupportedStrategies = do
     config <- asks getUnleashConfig
     now <- liftIO getCurrentTime
     let registrationPayload :: RegisterPayload
         registrationPayload =
             RegisterPayload
                 { appName = config.applicationName,
                   instanceId = config.instanceId,
+                  strategies = defaultSupportedStrategies <> customSupportedStrategies,
                   started = now,
                   intervalSeconds = config.metricsPushIntervalInSeconds
                 }
     void <$> register config.httpClientEnvironment config.apiKey registrationPayload
 
 -- | Fetch the most recent feature toggle set from the Unleash server. Meant to be run every statePollIntervalInSeconds. Non-blocking.
 pollToggles :: (HasUnleash r, MonadReader r m, MonadIO m) => m (Either ClientError ())
-pollToggles = do
+pollToggles = pollTogglesWithCustomStrategies defaultStrategyEvaluator
+
+-- | Fetch the most recent feature toggle set from the Unleash server. Custom strategies are added to default strategies. Meant to be run every statePollIntervalInSeconds. Non-blocking.
+pollTogglesWithCustomStrategies :: (HasUnleash r, MonadReader r m, MonadIO m) => StrategyEvaluator -> m (Either ClientError ())
+pollTogglesWithCustomStrategies customStrategyEvaluator = do
     config <- asks getUnleashConfig
-    eitherFeatures <- getAllClientFeatures config.httpClientEnvironment config.apiKey
+    eitherFeatures <- getAllClientFeatures config.httpClientEnvironment strategyEvaluator config.apiKey
     either (const $ pure ()) (updateState config.state) eitherFeatures
     pure . void $ eitherFeatures
     where
+        strategyEvaluator :: StrategyEvaluator
+        strategyEvaluator = withCustomStrategyEvaluator customStrategyEvaluator
         updateState state value = do
             isUpdated <- liftIO $ tryPutMVar state value
             liftIO . unless isUpdated . void $ swapMVar state value
 
+withCustomStrategyEvaluator :: StrategyEvaluator -> StrategyEvaluator
+withCustomStrategyEvaluator customStrategyEvaluator featureToggleName jsonStrategy ctx = do
+    defaultResult <- defaultStrategyEvaluator featureToggleName jsonStrategy ctx
+    customResult <- customStrategyEvaluator featureToggleName jsonStrategy ctx
+    pure $ defaultResult || customResult
+
 -- | Push metrics to the Unleash server. Meant to be run every metricsPushIntervalInSeconds. Blocks if the mutable metrics variables are empty.
 pushMetrics :: (HasUnleash r, MonadReader r m, MonadIO m) => m (Either ClientError ())
 pushMetrics = do

src/Unleash/Internal/HttpClient.hs

@@ -22,7 +22,8 @@ import qualified Network.HTTP.Media as M
 import Paths_unleash_client_haskell (version)
 import Servant.API (Accept (contentTypes), Get, Header, JSON, MimeRender (mimeRender), NoContent, PostNoContent, ReqBody, type (:<|>) (..), type (:>))
 import Servant.Client (ClientEnv, ClientError, client, runClientM)
-import Unleash.Internal.DomainTypes (Features, fromJsonFeatures, supportedStrategies)
+import Unleash (Features, StrategyEvaluator)
+import Unleash.Internal.DomainTypes (fromJsonFeatures)
 import Unleash.Internal.JsonTypes (FullMetricsBucket (..), FullMetricsPayload (..), FullRegisterPayload (..), MetricsPayload, RegisterPayload, YesAndNoes (..))
 import qualified Unleash.Internal.JsonTypes as UJT
 
@@ -56,16 +57,16 @@ register clientEnv apiKey registerPayload = do
                 { appName = registerPayload.appName,
                   instanceId = registerPayload.instanceId,
                   sdkVersion = "unleash-client-haskell:" <> (T.pack . showVersion) version,
-                  strategies = supportedStrategies,
+                  strategies = registerPayload.strategies,
                   started = registerPayload.started,
                   interval = registerPayload.intervalSeconds * 1000
                 }
     liftIO $ runClientM (register' apiKey (Just "application/json") fullRegisterPayload) clientEnv
 
-getAllClientFeatures :: MonadIO m => ClientEnv -> Maybe ApiKey -> m (Either ClientError Features)
-getAllClientFeatures clientEnv apiKey = do
+getAllClientFeatures :: MonadIO m => ClientEnv -> StrategyEvaluator -> Maybe ApiKey -> m (Either ClientError Features)
+getAllClientFeatures clientEnv strategyEvaluator apiKey = do
     eitherFeatures <- liftIO $ runClientM (getAllClientFeatures' apiKey) clientEnv
-    pure $ fromJsonFeatures <$> eitherFeatures
+    pure $ fromJsonFeatures strategyEvaluator <$> eitherFeatures
 
 sendMetrics :: MonadIO m => ClientEnv -> Maybe ApiKey -> MetricsPayload -> m (Either ClientError NoContent)
 sendMetrics clientEnv apiKey metricsPayload = do