diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,128 @@
+## 0.8.9 (2023-09-14)
+
+* Add CHANGELOG.md ([d72bcba](https://github.com/finn-no/unleash-client-haskell-core/commit/d72bcba))
+* Set version to 0.8.9 ([04a0260](https://github.com/finn-no/unleash-client-haskell-core/commit/04a0260))
+
+
+
+## 0.8.8 (2023-09-14)
+
+* Don't do -O2 ([107f9eb](https://github.com/finn-no/unleash-client-haskell-core/commit/107f9eb))
+* Set version to 0.8.8 ([42430b8](https://github.com/finn-no/unleash-client-haskell-core/commit/42430b8))
+* Sort deps ([980d827](https://github.com/finn-no/unleash-client-haskell-core/commit/980d827))
+
+
+
+## 0.8.7 (2023-09-14)
+
+* Downgrade Cabal to 3.0 ([748a219](https://github.com/finn-no/unleash-client-haskell-core/commit/748a219))
+* Set version to 0.8.7 ([98dda86](https://github.com/finn-no/unleash-client-haskell-core/commit/98dda86))
+* Version bound all deps ([fab23f9](https://github.com/finn-no/unleash-client-haskell-core/commit/fab23f9))
+
+
+
+## 0.8.6 (2023-09-13)
+
+* Add some more package properties ([94b9291](https://github.com/finn-no/unleash-client-haskell-core/commit/94b9291))
+* Set version to 0.8.6 ([7ca0655](https://github.com/finn-no/unleash-client-haskell-core/commit/7ca0655))
+
+
+
+## 0.8.5 (2023-02-27)
+
+* Build with -haddock ([51a53bb](https://github.com/finn-no/unleash-client-haskell-core/commit/51a53bb))
+* Set version to 0.8.5 ([7e5c174](https://github.com/finn-no/unleash-client-haskell-core/commit/7e5c174))
+
+
+
+## 0.8.4 (2023-02-06)
+
+* Export some things that should not have been removed ([8fb9158](https://github.com/finn-no/unleash-client-haskell-core/commit/8fb9158))
+* Set version to 0.8.4 ([bf929bc](https://github.com/finn-no/unleash-client-haskell-core/commit/bf929bc))
+
+
+
+## 0.8.3 (2023-02-06)
+
+* Set to version 0.8.3 ([95bb955](https://github.com/finn-no/unleash-client-haskell-core/commit/95bb955))
+* Update documentation ([e48a1c4](https://github.com/finn-no/unleash-client-haskell-core/commit/e48a1c4))
+
+
+
+## 0.8.2 (2023-02-06)
+
+* Export more fields from domain types ([1feac60](https://github.com/finn-no/unleash-client-haskell-core/commit/1feac60))
+* Set version to 0.8.2 ([219c5e2](https://github.com/finn-no/unleash-client-haskell-core/commit/219c5e2))
+
+
+
+## 0.8.1 (2023-02-06)
+
+* Add Haddock markup ([8d410ee](https://github.com/finn-no/unleash-client-haskell-core/commit/8d410ee))
+* Export all fields from VariantResponse ([5219d4b](https://github.com/finn-no/unleash-client-haskell-core/commit/5219d4b))
+* Export types used by Features from DomainTypes ([0f4f322](https://github.com/finn-no/unleash-client-haskell-core/commit/0f4f322))
+* Set version to 0.8.1 ([0c0d7f8](https://github.com/finn-no/unleash-client-haskell-core/commit/0c0d7f8))
+* Update README.md ([a60c0ce](https://github.com/finn-no/unleash-client-haskell-core/commit/a60c0ce))
+* Update README.md ([70c8e82](https://github.com/finn-no/unleash-client-haskell-core/commit/70c8e82))
+* Update README.md ([f5e57b1](https://github.com/finn-no/unleash-client-haskell-core/commit/f5e57b1))
+* Update README.md ([0d76c54](https://github.com/finn-no/unleash-client-haskell-core/commit/0d76c54))
+* Update README.md ([78ec126](https://github.com/finn-no/unleash-client-haskell-core/commit/78ec126))
+
+
+
+## 0.8.0 (2023-01-26)
+
+* Move HttpClient to unleash-client-haskell ([d060741](https://github.com/finn-no/unleash-client-haskell-core/commit/d060741))
+* Set version to 0.8.0 ([1fafeb0](https://github.com/finn-no/unleash-client-haskell-core/commit/1fafeb0))
+* Update README.md ([6c3c569](https://github.com/finn-no/unleash-client-haskell-core/commit/6c3c569))
+
+
+
+## 0.7.0 (2023-01-25)
+
+* Move example-client out of this repo ([a5bac9b](https://github.com/finn-no/unleash-client-haskell-core/commit/a5bac9b))
+* Set to version 0.7.0 ([afee708](https://github.com/finn-no/unleash-client-haskell-core/commit/afee708))
+* Use MonadIO in HttpClient (too) ([8d601a6](https://github.com/finn-no/unleash-client-haskell-core/commit/8d601a6))
+
+
+
+## 0.6.6 (2023-01-25)
+
+* Add example client (#4) ([4b93ff5](https://github.com/finn-no/unleash-client-haskell-core/commit/4b93ff5)), closes [#4](https://github.com/finn-no/unleash-client-haskell-core/issues/4)
+* Export emptyVariantResponse ([0f2f81f](https://github.com/finn-no/unleash-client-haskell-core/commit/0f2f81f))
+* Refactor constraintsPredicate ([8366f11](https://github.com/finn-no/unleash-client-haskell-core/commit/8366f11))
+* Remove comments in .hlint.yaml ([d64ea8b](https://github.com/finn-no/unleash-client-haskell-core/commit/d64ea8b))
+* Remove obsolete maintainer ([b03ba52](https://github.com/finn-no/unleash-client-haskell-core/commit/b03ba52))
+* Set to version 0.6.6 ([a565e6d](https://github.com/finn-no/unleash-client-haskell-core/commit/a565e6d))
+* Tidy up Cabal file ([16d77b2](https://github.com/finn-no/unleash-client-haskell-core/commit/16d77b2))
+* Update hie.yaml ([dad0c02](https://github.com/finn-no/unleash-client-haskell-core/commit/dad0c02))
+* Update README.md ([d052a17](https://github.com/finn-no/unleash-client-haskell-core/commit/d052a17))
+* Flake: Add overlay ([340a894](https://github.com/finn-no/unleash-client-haskell-core/commit/340a894))
+* Flake: Remove overlay ([ae0ae24](https://github.com/finn-no/unleash-client-haskell-core/commit/ae0ae24))
+
+
+
+## 0.6.5 (2023-01-19)
+
+* Bump version to 0.6.5 ([577b321](https://github.com/finn-no/unleash-client-haskell-core/commit/577b321))
+* Refactor predicates ([8ab1d8f](https://github.com/finn-no/unleash-client-haskell-core/commit/8ab1d8f))
+* Remove unused imports ([1b20f4c](https://github.com/finn-no/unleash-client-haskell-core/commit/1b20f4c))
+
+
+
+## 0.6.4 (2023-01-18)
+
+* Add comment ([ee8a722](https://github.com/finn-no/unleash-client-haskell-core/commit/ee8a722))
+* Add flake (with non-flake compat) ([8f3ad4b](https://github.com/finn-no/unleash-client-haskell-core/commit/8f3ad4b))
+* Add hie.yaml ([c95b28c](https://github.com/finn-no/unleash-client-haskell-core/commit/c95b28c))
+* Bump version to 0.6.4 ([3942cc5](https://github.com/finn-no/unleash-client-haskell-core/commit/3942cc5))
+* Get Cabal version from Paths_* ([178de38](https://github.com/finn-no/unleash-client-haskell-core/commit/178de38))
+* Update README.md ([0878348](https://github.com/finn-no/unleash-client-haskell-core/commit/0878348))
+
+
+
+## 0.6.3 (2022-12-15)
+
+* Add update-nixpkgs.rb ([c3474e7](https://github.com/finn-no/unleash-client-haskell-core/commit/c3474e7))
+* Initial commit ([21a895d](https://github.com/finn-no/unleash-client-haskell-core/commit/21a895d))
+* Update README.md ([a68abdf](https://github.com/finn-no/unleash-client-haskell-core/commit/a68abdf))
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,44 @@
+# unleash-client-haskell-core
+
+This is a library for evaluating [Unleash](https://www.getunleash.io/) feature toggles. It currently meets all [client specifications per v4.2.2](https://github.com/Unleash/client-specification/releases/tag/v4.2.2).
+
+The `Unleash` module provides functions and types for checking feature toggles and variants.
+
+Does not include an HTTP client. See [unleash-client-haskell](https://github.com/finn-no/unleash-client-haskell) for a ready-to-use Haskell Unleash client SDK.
+
+## Build
+
+```
+nix-build
+```
+
+## Run tests
+
+```
+# Fetch Unleash specification
+git submodule init
+git submodule update
+
+nix-shell
+cabal test
+```
+
+## Maintainers
+
+- [Eirik Meland](mailto:eirik.meland@gmail.com)
+- [Even Brenden](mailto:evenbrenden@gmail.com)
+
+## Dependencies
+
+- aeson (BSD-3-Clause)
+- aeson-pretty (BSD-3-Clause)
+- attoparsec (BSD-3-Clause)
+- bytestring (BSD-3-Clause)
+- containers (BSD-3-Clause)
+- hspec (MIT)
+- murmur3 (MIT)
+- random (BSD-3-Clause)
+- text (BSD-2-Clause)
+- text-show (BSD-3-Clause)
+- time (BSD-2-Clause)
+- versions (BSD-3-Clause)
diff --git a/src/Unleash.hs b/src/Unleash.hs
new file mode 100644
--- /dev/null
+++ b/src/Unleash.hs
@@ -0,0 +1,22 @@
+{- |
+Module : Unleash
+Copyright : Copyright © FINN.no AS, Inc. All rights reserved.
+License : MIT
+Stability : experimental
+
+Functions and types for checking feature toggles and variants.
+-}
+module Unleash (
+ Features,
+ Context (..),
+ emptyContext,
+ emptyVariantResponse,
+ featureIsEnabled,
+ featureGetVariant,
+ MetricsPayload (..),
+ RegisterPayload (..),
+ VariantResponse (..),
+) where
+
+import Unleash.Internal.DomainTypes (Features, featureGetVariant, featureIsEnabled)
+import Unleash.Internal.JsonTypes (Context (..), MetricsPayload (..), RegisterPayload (..), VariantResponse (..), emptyContext, emptyVariantResponse)
diff --git a/src/Unleash/Internal/DomainTypes.hs b/src/Unleash/Internal/DomainTypes.hs
new file mode 100644
--- /dev/null
+++ b/src/Unleash/Internal/DomainTypes.hs
@@ -0,0 +1,377 @@
+{- |
+Module : Unleash.Internal.DomainTypes
+Copyright : Copyright © FINN.no AS, Inc. All rights reserved.
+License : MIT
+Stability : experimental
+
+Domain types and evaluation functions.
+-}
+module Unleash.Internal.DomainTypes (
+ featureGetVariant,
+ featureIsEnabled,
+ fromJsonFeatures,
+ supportedStrategies,
+ Feature (..),
+ Features,
+ FeatureToggleName,
+ GetVariant (..),
+ IsEnabled (..),
+) where
+import Control.Applicative (liftA2, (<|>))
+import Control.Monad.IO.Class (MonadIO)
+import Data.Hash.Murmur (murmur3)
+import Data.List (find)
+import Data.Map.Strict (Map, fromList)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Text.Encoding (encodeUtf8)
+import Data.Word (Word32)
+import System.Random (randomRIO)
+import TextShow (showt)
+import Unleash.Internal.JsonTypes (Variant, VariantResponse (..), emptyVariantResponse)
+import qualified Unleash.Internal.JsonTypes as JsonTypes
+import Unleash.Internal.Predicates (datePredicate, numPredicate, semVerPredicate)
+
+-- | A list of currently supported strategies for this library.
+supportedStrategies :: [Text]
+supportedStrategies = ["default", "userWithId", "gradualRolloutUserId", "gradualRolloutSessionId", "gradualRolloutRandom", "remoteAddress", "flexibleRollout"]
+
+-- | Alias used for feature toggle names (as they are represented on Unleash servers).
+type FeatureToggleName = Text
+
+-- | Map of feature toggles keyed on toggle names. Typically the full set of features fetched from a server.
+type Features = Map FeatureToggleName Feature
+
+-- | Map of feature toggles keyed on strategy parameters.
+type Parameters = Map Text FeatureToggleName
+
+-- | Feature toggle state getter.
+newtype IsEnabled = IsEnabled (forall m. MonadIO m => JsonTypes.Context -> m Bool)
+
+-- | Feature toggle variant getter.
+newtype GetVariant = GetVariant (forall m. MonadIO m => JsonTypes.Context -> m VariantResponse)
+
+-- | Feature toggle.
+data Feature = Feature
+ { -- | Feature toggle state getter.
+ isEnabled :: IsEnabled,
+ -- | Feature toggle variant getter.
+ getVariant :: GetVariant
+ }
+
+segmentMap :: Maybe [JsonTypes.Segment] -> Map Int [JsonTypes.Constraint]
+segmentMap maybeSegments =
+ let segments :: [JsonTypes.Segment] = concat maybeSegments
+ in fromList $ (\segment -> (segment.id, segment.constraints)) <$> segments
+
+-- | Feature toggle set domain transfer object to domain type converter.
+fromJsonFeatures :: JsonTypes.Features -> Features
+fromJsonFeatures jsonFeatures = fromList $ fmap (fromJsonFeature (segmentMap jsonFeatures.segments)) jsonFeatures.features
+
+generateRandomText :: MonadIO m => m Text
+generateRandomText = showt <$> randomRIO @Int (0, 99999)
+
+fromJsonFeature :: Map Int [JsonTypes.Constraint] -> JsonTypes.Feature -> (FeatureToggleName, Feature)
+fromJsonFeature segmentMap jsonFeature =
+ ( jsonFeature.name,
+ Feature
+ { isEnabled = IsEnabled $ \ctx -> do
+ isAnyStrategyEnabled <- anyStrategyEnabled ctx
+ pure $ jsonFeature.enabled && (null jsonFeature.strategies || isAnyStrategyEnabled),
+ getVariant = GetVariant $ \ctx ->
+ if not jsonFeature.enabled
+ then pure emptyVariantResponse
+ else do
+ let variants :: [Variant] = fromMaybe [] jsonFeature.variants
+ case enabledByOverride variants ctx of
+ Just variant ->
+ -- Has overrides
+ pure $
+ VariantResponse
+ { name = variant.name,
+ payload = variant.payload,
+ enabled = True
+ }
+ Nothing -> do
+ -- Does not have overrides
+ let maybeStickiness = find ("default" /=) . catMaybes $ (.stickiness) <$> variants
+ case maybeStickiness of
+ Just stickiness -> do
+ -- Has non-default stickiness
+ let identifier = lookupContextValue stickiness ctx
+ selectVariant variants identifier jsonFeature.name
+ Nothing -> do
+ -- Default stickiness
+ let identifier = ctx.userId <|> ctx.sessionId <|> ctx.remoteAddress
+ selectVariant variants identifier jsonFeature.name
+ }
+ )
+ where
+ anyStrategyEnabled :: MonadIO m => JsonTypes.Context -> m Bool
+ anyStrategyEnabled ctx = or <$> traverse (\f -> f ctx) strategyPredicates
+
+ strategyPredicates :: MonadIO m => [JsonTypes.Context -> m Bool]
+ strategyPredicates =
+ fmap (fromJsonStrategy jsonFeature.name segmentMap) jsonFeature.strategies
+
+ enabledByOverride :: [Variant] -> JsonTypes.Context -> Maybe Variant
+ enabledByOverride variants ctx =
+ find
+ ( \variant -> case variant.overrides of
+ Nothing -> False
+ Just overrides ->
+ any
+ ( \override ->
+ lookupContextValue override.contextName ctx `elem` (Just <$> override.values)
+ )
+ overrides
+ )
+ variants
+
+ selectVariant :: MonadIO m => [Variant] -> Maybe Text -> Text -> m VariantResponse
+ selectVariant variants maybeIdentifier featureName = do
+ randomValue <- generateRandomText
+ let identifier = fromMaybe randomValue maybeIdentifier
+ weights = (.weight) <$> variants
+ hashed = getNormalizedNumberN identifier featureName (fromIntegral $ sum weights)
+ accumulated = tail $ scanl (+) 0 weights
+ zipped = zip accumulated variants
+ maybeVariant = snd <$> find (\(acc, _) -> acc >= hashed) zipped
+ in case maybeVariant of
+ Nothing -> pure emptyVariantResponse
+ Just variant ->
+ pure $
+ VariantResponse
+ { name = variant.name,
+ payload = variant.payload,
+ enabled = True
+ }
+
+fromJsonStrategy :: MonadIO m => FeatureToggleName -> Map Int [JsonTypes.Constraint] -> JsonTypes.Strategy -> (JsonTypes.Context -> m Bool)
+fromJsonStrategy featureToggleName segmentMap jsonStrategy =
+ \ctx -> liftA2 (&&) (strategyFunction ctx) (constraintsPredicate ctx)
+ where
+ strategyFunction :: MonadIO m => JsonTypes.Context -> m Bool
+ strategyFunction =
+ case jsonStrategy.name of
+ "default" -> pure . \_ctx -> True
+ "userWithId" ->
+ pure . \ctx ->
+ let strategy params =
+ let userIds = maybe [] (Text.splitOn ", ") (Map.lookup "userIds" params)
+ in ctx.userId `elem` (Just <$> userIds)
+ in evaluateStrategy strategy jsonStrategy.parameters
+ "gradualRolloutUserId" ->
+ pure . \ctx ->
+ case ctx.userId of
+ Nothing -> False
+ Just userId ->
+ evaluateStrategy strategy jsonStrategy.parameters
+ where
+ strategy params =
+ let percentage = getInt "percentage" params
+ groupId = fromMaybe featureToggleName $ Map.lookup "groupId" params
+ normValue = getNormalizedNumber userId groupId
+ in normValue <= percentage
+ "gradualRolloutSessionId" ->
+ pure . \ctx ->
+ case ctx.sessionId of
+ Nothing -> False
+ Just sessionId ->
+ evaluateStrategy strategy jsonStrategy.parameters
+ where
+ strategy params =
+ let percentage = getInt "percentage" params
+ groupId = fromMaybe featureToggleName $ Map.lookup "groupId" params
+ normValue = getNormalizedNumber sessionId groupId
+ in normValue <= percentage
+ "gradualRolloutRandom" -> \_ctx -> do
+ case jsonStrategy.parameters of
+ Nothing -> pure False
+ Just params -> do
+ let percentage = getInt "percentage" params
+ num <- randomRIO @Int (1, 100)
+ pure $ percentage >= num
+ "remoteAddress" ->
+ pure . \ctx ->
+ let strategy params =
+ let remoteAddresses = maybe [] (Text.splitOn ", ") (Map.lookup "IPs" params)
+ in ctx.remoteAddress `elem` (Just <$> remoteAddresses)
+ in evaluateStrategy strategy jsonStrategy.parameters
+ "flexibleRollout" -> \ctx -> do
+ randomValue <- generateRandomText
+ let strategy params =
+ let rollout = getInt "rollout" params
+ stickiness = fromMaybe "default" $ Map.lookup "stickiness" params
+ groupId = fromMaybe featureToggleName $ Map.lookup "groupId" params
+ in case stickiness of
+ "default" ->
+ normalizedNumber <= rollout
+ where
+ identifier = fromMaybe randomValue (ctx.userId <|> ctx.sessionId <|> ctx.remoteAddress)
+ normalizedNumber = getNormalizedNumber identifier groupId
+ "userId" ->
+ case ctx.userId of
+ Nothing -> False
+ Just userId -> getNormalizedNumber userId groupId <= rollout
+ "sessionId" ->
+ case ctx.sessionId of
+ Nothing -> False
+ Just sessionId -> getNormalizedNumber sessionId groupId <= rollout
+ customField ->
+ case lookupContextValue customField ctx of
+ Nothing -> False
+ Just customValue ->
+ getNormalizedNumber customValue groupId <= rollout
+ in pure $ evaluateStrategy strategy jsonStrategy.parameters
+ -- Unknown strategy
+ _ -> pure . \_ctx -> False
+
+ segmentsToConstraints :: [Int] -> Map Int [JsonTypes.Constraint] -> [Maybe JsonTypes.Constraint]
+ segmentsToConstraints segmentReferences segmentMap =
+ concat $ sequence <$> ((flip Map.lookup) segmentMap <$> segmentReferences)
+
+ constraintsPredicate :: MonadIO m => JsonTypes.Context -> m Bool
+ constraintsPredicate ctx = do
+ let segmentReferences = concat jsonStrategy.segments
+ maybeSegmentConstraints = segmentsToConstraints segmentReferences segmentMap
+ segmentConstraints = catMaybes maybeSegmentConstraints
+ strategyConstraints = fromMaybe [] jsonStrategy.constraints
+ allConstraints = segmentConstraints <> strategyConstraints
+ allPredicates = fromJsonConstraint <$> allConstraints
+ allSegmentConstraintsAreReferredTo = not $ Nothing `elem` maybeSegmentConstraints
+ allPredicatesAreSatisfied = allSegmentConstraintsAreReferredTo && and (evaluatePredicate <$> allPredicates)
+ thereAreNoPredicates = null allPredicates
+ pure $ thereAreNoPredicates || allPredicatesAreSatisfied
+ where
+ evaluatePredicate :: (JsonTypes.Context -> Bool) -> Bool
+ evaluatePredicate f = f ctx
+
+fromJsonConstraint :: JsonTypes.Constraint -> (JsonTypes.Context -> Bool)
+fromJsonConstraint constraint = \ctx -> do
+ let constraintValues =
+ if fromMaybe False constraint.caseInsensitive
+ then Text.toLower <$> fromMaybe [] constraint.values
+ else fromMaybe [] constraint.values
+
+ let mCurrentValue = do
+ let tmpValue :: Maybe Text = lookupContextValue constraint.contextName ctx
+ if fromMaybe False constraint.caseInsensitive
+ then (Text.toLower <$> tmpValue)
+ else tmpValue
+
+ let result =
+ case constraint.operator of
+ "IN" -> mCurrentValue `isIn` constraintValues
+ "NOT_IN" -> mCurrentValue `isNotIn` constraintValues
+ "STR_STARTS_WITH" -> mCurrentValue `startsWithAnyOf` constraintValues
+ "STR_ENDS_WITH" -> mCurrentValue `endsWithAnyOf` constraintValues
+ "STR_CONTAINS" -> mCurrentValue `containsAnyOf` constraintValues
+ "NUM_EQ" -> numPredicate (==) mCurrentValue constraint.value
+ "NUM_GT" -> numPredicate (>) mCurrentValue constraint.value
+ "NUM_GTE" -> numPredicate (>=) mCurrentValue constraint.value
+ "NUM_LTE" -> numPredicate (<=) mCurrentValue constraint.value
+ "NUM_LT" -> numPredicate (<) mCurrentValue constraint.value
+ "DATE_AFTER" -> datePredicate (>) mCurrentValue constraint.value
+ "DATE_BEFORE" -> datePredicate (<) mCurrentValue constraint.value
+ "SEMVER_EQ" -> semVerPredicate (==) mCurrentValue constraint.value
+ "SEMVER_GT" -> semVerPredicate (>) mCurrentValue constraint.value
+ "SEMVER_LT" -> semVerPredicate (<) mCurrentValue constraint.value
+ _ -> False
+
+ if fromMaybe False constraint.inverted
+ then not result
+ else result
+
+lookupContextValue :: Text -> JsonTypes.Context -> Maybe Text
+lookupContextValue key ctx =
+ case key of
+ "appName" -> ctx.appName
+ "currentTime" -> ctx.currentTime
+ "environment" -> ctx.environment
+ "remoteAddress" -> ctx.remoteAddress
+ "sessionId" -> ctx.sessionId
+ "userId" -> ctx.userId
+ propertiesKey -> do
+ m <- ctx.properties
+ value <- Map.lookup propertiesKey m
+ value
+
+isIn :: Eq a => Maybe a -> [a] -> Bool
+isIn mCurrentValue values =
+ case mCurrentValue of
+ Nothing -> False
+ Just currentValue -> currentValue `elem` values
+
+isNotIn :: Eq a => Maybe a -> [a] -> Bool
+isNotIn mCurrentValue values = not $ isIn mCurrentValue values
+
+startsWithAnyOf :: Maybe Text -> [Text] -> Bool
+startsWithAnyOf mCurrentValue values = do
+ case mCurrentValue of
+ Nothing -> False
+ Just currentValue -> any (`Text.isPrefixOf` currentValue) values
+
+endsWithAnyOf :: Maybe Text -> [Text] -> Bool
+endsWithAnyOf mCurrentValue values = do
+ case mCurrentValue of
+ Nothing -> False
+ Just currentValue -> any (`Text.isSuffixOf` currentValue) values
+
+containsAnyOf :: Maybe Text -> [Text] -> Bool
+containsAnyOf mCurrentValue values = do
+ case mCurrentValue of
+ Nothing -> False
+ Just currentValue -> any (`Text.isInfixOf` currentValue) values
+
+getNormalizedNumberN :: Text -> Text -> Word32 -> Int
+getNormalizedNumberN identifier groupId n = do
+ let s = groupId <> ":" <> identifier
+ let hash :: Word32 = murmur3 (0 :: Word32) $ encodeUtf8 s
+
+ fromIntegral $ (mod hash n) + 1
+
+getNormalizedNumber :: Text -> Text -> Int
+getNormalizedNumber identifier groupId = getNormalizedNumberN identifier groupId 100
+
+-- | Check whether or not a feature toggle is enabled.
+featureIsEnabled ::
+ MonadIO m =>
+ -- | Full set of features fetched from a server.
+ Features ->
+ -- | Feature toggle name (as it is represented on the server).
+ FeatureToggleName ->
+ -- | User context.
+ JsonTypes.Context ->
+ -- | Feature toggle state.
+ m Bool
+featureIsEnabled state toggleName ctx = do
+ let mToggle :: Maybe Feature = Map.lookup toggleName state
+ case mToggle of
+ Just Feature {isEnabled = IsEnabled isEnabled} -> isEnabled ctx
+ Nothing -> pure False
+
+getInt :: Text -> Parameters -> Int
+getInt key params = read . Text.unpack $ fromMaybe "0" (Map.lookup key params)
+
+evaluateStrategy :: (a -> Bool) -> Maybe a -> Bool
+evaluateStrategy f p = maybe False f p
+
+-- | Get a variant for a given feature toggle.
+featureGetVariant ::
+ MonadIO m =>
+ -- | Full set of features fetched from a server.
+ Features ->
+ -- | Feature toggle name (as it is represented on the server).
+ FeatureToggleName ->
+ -- | User context.
+ JsonTypes.Context ->
+ -- | Variant.
+ m VariantResponse
+featureGetVariant state toggleName ctx = do
+ let mToggle :: Maybe Feature = Map.lookup toggleName state
+ case mToggle of
+ Just Feature {getVariant = GetVariant getVariant} -> getVariant ctx
+ Nothing -> pure emptyVariantResponse
diff --git a/src/Unleash/Internal/JsonTypes.hs b/src/Unleash/Internal/JsonTypes.hs
new file mode 100644
--- /dev/null
+++ b/src/Unleash/Internal/JsonTypes.hs
@@ -0,0 +1,255 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+{- |
+Module : Unleash.Internal.JsonTypes
+Copyright : Copyright © FINN.no AS, Inc. All rights reserved.
+License : MIT
+Stability : experimental
+
+Unleash domain transfer objects.
+-}
+module Unleash.Internal.JsonTypes (
+ Features (..),
+ Feature (..),
+ Strategy (..),
+ Constraint (..),
+ Variant (..),
+ Payload (..),
+ Override (..),
+ Context (..),
+ emptyContext,
+ Segment (..),
+ VariantResponse (..),
+ emptyVariantResponse,
+ MetricsPayload (..),
+ FullMetricsPayload (..),
+ FullMetricsBucket (..),
+ YesAndNoes (..),
+ FullRegisterPayload (..),
+ RegisterPayload (..),
+) where
+
+import Data.Aeson (FromJSON, Options (..), ToJSON (toJSON), defaultOptions, genericParseJSON, genericToJSON)
+import Data.Aeson.Types (parseJSON)
+import Data.Map.Strict (Map)
+import Data.Text (Text)
+import Data.Time (UTCTime)
+import GHC.Generics (Generic)
+
+-- | Feature toggle set.
+data Features = Features
+ { version :: Int,
+ features :: [Feature],
+ segments :: Maybe [Segment]
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+-- | Feature toggle.
+data Feature = Feature
+ { name :: Text,
+ description :: Maybe Text,
+ enabled :: Bool,
+ strategies :: [Strategy],
+ variants :: Maybe [Variant]
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+-- | Strategy. Encompasses all (supported) types of strategies.
+data Strategy = Strategy
+ { name :: Text,
+ parameters :: Maybe (Map Text Text),
+ constraints :: Maybe [Constraint],
+ segments :: Maybe [Int]
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+-- | Strategy constraint.
+data Constraint = Constraint
+ { contextName :: Text,
+ operator :: Text,
+ values :: Maybe [Text],
+ caseInsensitive :: Maybe Bool,
+ inverted :: Maybe Bool,
+ value :: Maybe Text
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+-- | Variant.
+data Variant = Variant
+ { name :: Text,
+ payload :: Maybe Payload,
+ weight :: Int,
+ stickiness :: Maybe Text,
+ overrides :: Maybe [Override]
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+typeWorkAroundOptions :: Options
+typeWorkAroundOptions =
+ defaultOptions {fieldLabelModifier = typeWorkaround}
+ where
+ typeWorkaround :: String -> String
+ typeWorkaround s = case s of
+ "type" -> "type_"
+ "type_" -> "type"
+ _ -> s
+
+-- | Variant payload.
+data Payload = Payload
+ { -- | Payload type.
+ type_ :: Text,
+ -- | Payload.
+ value :: Text
+ }
+ deriving stock (Eq, Show, Generic)
+
+instance FromJSON Payload where
+ parseJSON = genericParseJSON typeWorkAroundOptions
+
+instance ToJSON Payload where
+ toJSON = genericToJSON typeWorkAroundOptions
+
+-- | Contextual override.
+data Override = Override
+ { contextName :: Text,
+ values :: [Text]
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+-- | Client context.
+data Context = Context
+ { -- | User ID.
+ userId :: Maybe Text,
+ -- | Session ID.
+ sessionId :: Maybe Text,
+ -- | Remote address.
+ remoteAddress :: Maybe Text,
+ -- | Current UTC time.
+ currentTime :: Maybe Text,
+ -- | Application environment (e.g. @Production@).
+ environment :: Maybe Text,
+ -- | Application name.
+ appName :: Maybe Text,
+ -- | Other custom properties.
+ properties :: Maybe (Map Text (Maybe Text))
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+-- | An initial client context.
+emptyContext :: Context
+emptyContext = Context Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+
+-- | Segment.
+data Segment = Segment
+ { id :: Int,
+ constraints :: [Constraint]
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+-- | Variant response.
+data VariantResponse = VariantResponse
+ { -- | Variant name.
+ name :: Text,
+ -- | Variant payload.
+ payload :: Maybe Payload,
+ -- | Variant state.
+ enabled :: Bool
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+-- | The default (disabled) variant response.
+emptyVariantResponse :: VariantResponse
+emptyVariantResponse =
+ VariantResponse
+ { name = "disabled",
+ payload = Nothing,
+ enabled = False
+ }
+
+-- | Metrics payload.
+data MetricsPayload = MetricsPayload
+ { -- | Application name.
+ appName :: Text,
+ -- | Instance identifier (typically hostname).
+ instanceId :: Text,
+ -- | Start timestamp for this interval.
+ start :: UTCTime,
+ -- | End timestamp for this interval.
+ stop :: UTCTime,
+ -- | Feature toggle usage metrics.
+ toggles :: [(Text, Bool)]
+ }
+ deriving stock (Eq, Show, Generic)
+
+-- | Full metrics payload.
+data FullMetricsPayload = FullMetricsPayload
+ { appName :: Text,
+ instanceId :: Text,
+ bucket :: FullMetricsBucket
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (ToJSON)
+
+-- | Full metrics bucket.
+data FullMetricsBucket = FullMetricsBucket
+ { -- | Start timestamp for this interval.
+ start :: UTCTime,
+ -- | End timestamp for this interval.
+ stop :: UTCTime,
+ -- | Feature toggle usage metrics.
+ toggles :: Map Text YesAndNoes
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (ToJSON)
+
+-- | Helper data structure for metrics.
+data YesAndNoes = YesAndNoes
+ { -- | The number of times the feature toggle was fetched as enabled in an interval.
+ yes :: Int,
+ -- | The number of times the feature toggle was fetched as disabled in an interval.
+ no :: Int
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (ToJSON)
+
+-- | Full client registration payload.
+data FullRegisterPayload = FullRegisterPayload
+ { -- | Application name.
+ appName :: Text,
+ -- | Instance identifier (typically hostname).
+ instanceId :: Text,
+ -- | Unleash client SDK version.
+ sdkVersion :: Text,
+ -- | Supported strategies.
+ strategies :: [Text],
+ -- | When the application was started.
+ started :: UTCTime,
+ -- | Expected metrics sending interval.
+ interval :: Int
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (ToJSON)
+
+-- | Client registration payload.
+data RegisterPayload = RegisterPayload
+ { -- | Application name.
+ appName :: Text,
+ -- | Instance identifier (typically hostname).
+ instanceId :: Text,
+ -- | Client application startup timestamp.
+ started :: UTCTime,
+ -- | Intended metrics sending interval.
+ intervalSeconds :: Int
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (ToJSON)
diff --git a/src/Unleash/Internal/Predicates.hs b/src/Unleash/Internal/Predicates.hs
new file mode 100644
--- /dev/null
+++ b/src/Unleash/Internal/Predicates.hs
@@ -0,0 +1,86 @@
+{- |
+Module : Unleash.Internal.Predicates
+Copyright : Copyright © FINN.no AS, Inc. All rights reserved.
+License : MIT
+Stability : experimental
+
+Predicate helpers.
+-}
+module Unleash.Internal.Predicates (
+ datePredicate,
+ numPredicate,
+ semVerPredicate,
+) where
+
+import Control.Applicative ((<|>))
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Time (UTCTime, zonedTimeToUTC)
+import Data.Time.Format.ISO8601 (iso8601ParseM)
+import Data.Time.LocalTime (ZonedTime)
+import Data.Versions (SemVer, semver)
+import Text.Read (readMaybe)
+
+-- | Evaluate a predicate for UTC times.
+datePredicate ::
+ -- | Predicate.
+ (UTCTime -> UTCTime -> Bool) ->
+ -- | First argument to predicate (to be parsed to UTC time).
+ Maybe Text ->
+ -- | Second argument to predicate (to be parsed to UTC time).
+ Maybe Text ->
+ -- | Predicate result.
+ Bool
+datePredicate predicate mCurrentValue mConstraintValue = do
+ let parseDate :: Text -> Maybe UTCTime
+ parseDate text =
+ (iso8601ParseM @Maybe @UTCTime $ Text.unpack text)
+ <|> zonedTimeToUTC <$> (iso8601ParseM @Maybe @ZonedTime $ Text.unpack text)
+
+ let mConstraintDate :: Maybe UTCTime = parseDate =<< mConstraintValue
+ let mProvidedDate :: Maybe UTCTime = parseDate =<< mCurrentValue
+
+ case (mProvidedDate, mConstraintDate) of
+ (Just providedDate, Just constraintDate) -> predicate providedDate constraintDate
+ _ -> False
+
+-- | Evaluate a predicate for numbers.
+numPredicate ::
+ -- | Predicate.
+ (Double -> Double -> Bool) ->
+ -- | First argument to predicate (to be parsed to UTC time).
+ Maybe Text ->
+ -- | Second argument to predicate (to be parsed to UTC time).
+ Maybe Text ->
+ -- | Predicate result.
+ Bool
+numPredicate predicate mCurrentValue mConstraintValue = do
+ let maybeCurrentValue :: Maybe Double = readMaybe . Text.unpack =<< mCurrentValue
+ let maybeConstraintValue :: Maybe Double = readMaybe . Text.unpack =<< mConstraintValue
+
+ case (maybeConstraintValue, maybeCurrentValue) of
+ (Just constraintValue, Just currentValue) -> predicate currentValue constraintValue
+ _ -> False
+
+-- | Evaluate a predicate for semantic versioning values.
+semVerPredicate ::
+ -- | Predicate.
+ (SemVer -> SemVer -> Bool) ->
+ -- | First argument to predicate (to be parsed to a version).
+ Maybe Text ->
+ -- | Second argument to predicate (to be parsed to a version).
+ Maybe Text ->
+ -- | Predicate result.
+ Bool
+semVerPredicate predicate mCurrentValue mConstraintValue = do
+ let eitherToMaybe e =
+ case e of
+ Right a -> Just a
+ _ -> Nothing
+
+ let mConstraintSemVer :: Maybe SemVer = eitherToMaybe . semver =<< mConstraintValue
+ let mProvidedSemVer :: Maybe SemVer = eitherToMaybe . semver =<< mCurrentValue
+
+ case (mProvidedSemVer, mConstraintSemVer) of
+ (Just providedSemVer, Just constraintSemVer) -> predicate providedSemVer constraintSemVer
+ _ -> False
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,2 @@
+-- Copyright © FINN.no AS, Inc. All rights reserved.
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/test/UnleashClientSpecificationRoundtripSpec.hs b/test/UnleashClientSpecificationRoundtripSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/UnleashClientSpecificationRoundtripSpec.hs
@@ -0,0 +1,70 @@
+-- Copyright © FINN.no AS, Inc. All rights reserved.
+
+module UnleashClientSpecificationRoundtripSpec (
+ spec,
+) where
+
+import Data.Aeson (ToJSON (toJSON), eitherDecodeFileStrict, eitherDecodeStrict)
+import qualified Data.Aeson as Aeson
+import Data.Aeson.Encode.Pretty (encodePretty)
+import Data.Aeson.KeyMap (mapMaybe)
+import qualified Data.Aeson.Parser as Parser
+import Data.Attoparsec.ByteString (parseOnly)
+import qualified Data.ByteString as BS (readFile)
+import qualified Data.ByteString.Lazy as BSL
+import Data.Foldable (traverse_)
+import Data.List (isPrefixOf)
+import Test.Hspec
+import UnleashSpecificationJsonTypes (Specification)
+
+spec :: Spec
+spec =
+ describe "Parse json specification" do
+ it "parse all specification files and check if input json is the same as serialized json" do
+ Right filepaths <- eitherDecodeFileStrict @([FilePath]) "./client-specification/specifications/index.json"
+
+ -- Test 13 contains null as a value that is deleted by WithoutNothing
+ let filepathsWO13 = filter (not . isPrefixOf "13") filepaths
+
+ let filepaths' = ("./client-specification/specifications/" <>) <$> filepathsWO13
+ traverse_ roundtrip filepaths'
+
+roundtrip :: FilePath -> Expectation
+roundtrip filePath = do
+ putStrLn (" " <> filePath)
+ bs <- BS.readFile filePath
+ let eJsonValue = parseOnly Parser.value bs
+ case eJsonValue of
+ Right _ -> pure ()
+ Left e -> print e
+ let Right jsonValue = eJsonValue
+ let prettyJson = encodePretty jsonValue
+
+ let eSpecification = eitherDecodeStrict @Specification bs
+ case eSpecification of
+ Right _ -> pure ()
+ Left e -> print e
+ let Right specification = eSpecification
+
+ BSL.writeFile "actual.json" $ encodePretty specification
+ BSL.writeFile "expected.json" prettyJson
+ encodePretty (WithoutNothing specification) `shouldBe` prettyJson
+
+removeUndefinedProps :: Aeson.Value -> Aeson.Value
+removeUndefinedProps v =
+ case v of
+ Aeson.Array v' -> Aeson.Array $ removeUndefinedProps <$> v'
+ Aeson.Object km ->
+ Aeson.Object $
+ mapMaybe
+ ( \v' -> case v' of
+ Aeson.Null -> Nothing
+ _ -> Just $ removeUndefinedProps v'
+ )
+ km
+ _ -> v
+
+newtype WithoutNothing a = WithoutNothing a
+
+instance (ToJSON a) => ToJSON (WithoutNothing a) where
+ toJSON (WithoutNothing a) = removeUndefinedProps $ toJSON a
diff --git a/test/UnleashSpecificationJsonTypes.hs b/test/UnleashSpecificationJsonTypes.hs
new file mode 100644
--- /dev/null
+++ b/test/UnleashSpecificationJsonTypes.hs
@@ -0,0 +1,37 @@
+-- Copyright © FINN.no AS, Inc. All rights reserved.
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module UnleashSpecificationJsonTypes where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Unleash.Internal.JsonTypes (Context, Features, VariantResponse)
+
+data Specification = Specification
+ { name :: Text,
+ state :: Features,
+ tests :: Maybe [Test],
+ variantTests :: Maybe [VariantTest]
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+data Test = Test
+ { description :: Text,
+ context :: Context,
+ toggleName :: Text,
+ expectedResult :: Bool
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
+
+data VariantTest = VariantTest
+ { description :: Text,
+ context :: Context,
+ toggleName :: Text,
+ expectedResult :: VariantResponse
+ }
+ deriving stock (Eq, Show, Generic)
+ deriving anyclass (FromJSON, ToJSON)
diff --git a/test/UnleashSpecificationSpec.hs b/test/UnleashSpecificationSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/UnleashSpecificationSpec.hs
@@ -0,0 +1,43 @@
+-- Copyright © FINN.no AS, Inc. All rights reserved.
+
+module UnleashSpecificationSpec (
+ spec,
+) where
+
+import Data.Aeson (eitherDecodeFileStrict)
+import Data.Foldable (traverse_)
+import Data.Maybe (fromMaybe)
+import Test.Hspec
+import Unleash.Internal.DomainTypes (featureGetVariant, featureIsEnabled, fromJsonFeatures)
+import qualified UnleashSpecificationJsonTypes as JsonTypes
+
+spec :: Spec
+spec =
+ describe "Run all specifications" do
+ it "run all specification files" do
+ Right filepaths <- eitherDecodeFileStrict @([FilePath]) "./client-specification/specifications/index.json"
+ let filepaths' = ("./client-specification/specifications/" <>) <$> filepaths
+ let implemented = filepaths'
+ traverse_ runSpecification implemented
+
+runSpecification :: FilePath -> Expectation
+runSpecification filePath = do
+ Right specification <- eitherDecodeFileStrict @JsonTypes.Specification filePath
+
+ let state = fromJsonFeatures specification.state
+
+ let isEnabled' :: JsonTypes.Test -> Expectation
+ isEnabled' sut = do
+ print sut.description
+ actual <- featureIsEnabled state sut.toggleName sut.context
+ actual `shouldBe` sut.expectedResult
+
+ traverse_ isEnabled' $ fromMaybe [] specification.tests
+
+ let getVariant' :: JsonTypes.VariantTest -> Expectation
+ getVariant' sut = do
+ print sut.description
+ variantResponse <- featureGetVariant state sut.toggleName sut.context
+ variantResponse `shouldBe` sut.expectedResult
+
+ traverse_ getVariant' $ fromMaybe [] specification.variantTests
diff --git a/unleash-client-haskell-core.cabal b/unleash-client-haskell-core.cabal
new file mode 100644
--- /dev/null
+++ b/unleash-client-haskell-core.cabal
@@ -0,0 +1,77 @@
+cabal-version: 3.0
+
+name: unleash-client-haskell-core
+version: 0.8.9
+synopsis: Unleash feature toggle client core
+description:
+ This is a library for evaluating [Unleash](https://www.getunleash.io/) feature toggles.
+ The 'Unleash' module provides functions and types for checking feature toggles and variants.
+category: Web
+author: FINN.no
+maintainer: [email protected]
+license: MIT
+copyright: Copyright © FINN.no AS, Inc. All rights reserved.
+extra-source-files:
+ CHANGELOG.md
+ README.md
+
+common all
+ build-depends:
+ base >=4.7 && <5,
+ record-dot-preprocessor >= 0.2.15 && < 0.3,
+ record-hasfield >= 1.0 && < 1.1,
+ default-extensions:
+ BlockArguments
+ DeriveFoldable
+ DeriveFunctor
+ DeriveTraversable
+ DerivingStrategies
+ LambdaCase
+ OverloadedStrings
+ RankNTypes
+ ScopedTypeVariables
+ ghc-options:
+ -haddock
+ -W
+ -Wno-unused-top-binds
+ -Wredundant-constraints
+ -Wunused-packages
+ -F -pgmF=record-dot-preprocessor
+ default-language: Haskell2010
+
+library
+ import: all
+ exposed-modules:
+ Unleash
+ Unleash.Internal.DomainTypes
+ Unleash.Internal.JsonTypes
+ Unleash.Internal.Predicates
+ hs-source-dirs: src
+ build-depends:
+ aeson >= 2.0.3 && < 2.1,
+ containers >= 0.6.4 && < 0.7,
+ murmur3 >= 1.0.5 && < 1.1,
+ random >= 1.2.1 && < 1.3,
+ text >= 1.2.5 && < 1.3,
+ text-show >= 3.9.7 && < 3.10,
+ time >= 1.9.3 && < 1.10,
+ versions >= 5.0.4 && < 5.1,
+
+test-suite unleash-client-haskell-core-test
+ import: all
+ ghc-options: -Wno-missing-home-modules
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs: test
+ other-modules:
+ UnleashClientSpecificationRoundtripSpec
+ UnleashSpecificationJsonTypes
+ UnleashSpecificationSpec
+ build-depends:
+ aeson,
+ aeson-pretty >= 0.8.9 && < 0.9,
+ attoparsec >= 0.14.4 && < 0.15,
+ bytestring >= 0.10.12 && < 0.11,
+ hspec >= 2.8.5 && < 2.9,
+ text,
+ unleash-client-haskell-core