unleash-client-haskell-core (empty) → 0.8.9
raw patch · 11 files changed
+1141/−0 lines, 11 filesdep +aesondep +aeson-prettydep +attoparsec
Dependencies added: aeson, aeson-pretty, attoparsec, base, bytestring, containers, hspec, murmur3, random, record-dot-preprocessor, record-hasfield, text, text-show, time, unleash-client-haskell-core, versions
Files
- CHANGELOG.md +128/−0
- README.md +44/−0
- src/Unleash.hs +22/−0
- src/Unleash/Internal/DomainTypes.hs +377/−0
- src/Unleash/Internal/JsonTypes.hs +255/−0
- src/Unleash/Internal/Predicates.hs +86/−0
- test/Spec.hs +2/−0
- test/UnleashClientSpecificationRoundtripSpec.hs +70/−0
- test/UnleashSpecificationJsonTypes.hs +37/−0
- test/UnleashSpecificationSpec.hs +43/−0
- unleash-client-haskell-core.cabal +77/−0
+ CHANGELOG.md view
@@ -0,0 +1,128 @@+## <small>0.8.9 (2023-09-14)</small>++* 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))++++## <small>0.8.8 (2023-09-14)</small>++* 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))++++## <small>0.8.7 (2023-09-14)</small>++* 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))++++## <small>0.8.6 (2023-09-13)</small>++* 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))++++## <small>0.8.5 (2023-02-27)</small>++* 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))++++## <small>0.8.4 (2023-02-06)</small>++* 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))++++## <small>0.8.3 (2023-02-06)</small>++* 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))++++## <small>0.8.2 (2023-02-06)</small>++* 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))++++## <small>0.8.1 (2023-02-06)</small>++* 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))++++## <small>0.6.6 (2023-01-25)</small>++* 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))++++## <small>0.6.5 (2023-01-19)</small>++* 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))++++## <small>0.6.4 (2023-01-18)</small>++* 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))++++## <small>0.6.3 (2022-12-15)</small>++* 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))
+ README.md view
@@ -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)
+ src/Unleash.hs view
@@ -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)
+ src/Unleash/Internal/DomainTypes.hs view
@@ -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
+ src/Unleash/Internal/JsonTypes.hs view
@@ -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)
+ src/Unleash/Internal/Predicates.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,2 @@+-- Copyright © FINN.no AS, Inc. All rights reserved.+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/UnleashClientSpecificationRoundtripSpec.hs view
@@ -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
+ test/UnleashSpecificationJsonTypes.hs view
@@ -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)
+ test/UnleashSpecificationSpec.hs view
@@ -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
+ unleash-client-haskell-core.cabal view
@@ -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