module Spec.Segment (allTests) where
import Data.Aeson.Types (Value (..))
import Data.Function ((&))
import Data.Generics.Product (getField)
import qualified Data.HashSet as HS
import Test.HUnit
import Util.Features
import LaunchDarkly.Server.Client
import LaunchDarkly.Server.Config
import LaunchDarkly.Server.Context (makeContext, withAttribute)
import LaunchDarkly.Server.Evaluate
import LaunchDarkly.Server.Features
import LaunchDarkly.Server.Operators
import LaunchDarkly.Server.Reference (makeLiteral)
import LaunchDarkly.Server.Store.Internal
makeEmptyStore = do
handle <- makeStoreIO Nothing 0
initializeStore handle mempty mempty
pure handle
makeTestClient :: IO Client
makeTestClient = do
client <- makeClient $ (makeConfig "") & configSetOffline True
initializeStore (getField @"store" client) mempty mempty
pure client
testExplicitIncludeUser :: Test
testExplicitIncludeUser = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right True)
segmentContainsContext store segment org HS.empty >>= assertEqual "" (Right False)
where
segment =
Segment
{ key = "test"
, included = HS.fromList ["foo"]
, includedContexts = mempty
, excluded = HS.empty
, excludedContexts = mempty
, salt = "abcdef"
, rules = []
, version = 1
, deleted = False
}
user = makeContext "foo" "user"
org = makeContext "foo" "org"
testExplicitIncludeContextKind :: Test
testExplicitIncludeContextKind = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right True)
segmentContainsContext store segment org HS.empty >>= assertEqual "" (Right False)
where
segment =
Segment
{ key = "test"
, included = HS.empty
, includedContexts = [SegmentTarget {values = HS.fromList ["foo"], contextKind = "user"}]
, excluded = HS.empty
, excludedContexts = mempty
, salt = "abcdef"
, rules = []
, version = 1
, deleted = False
}
user = makeContext "foo" "user"
org = makeContext "foo" "org"
testExplicitExcludeUser :: Test
testExplicitExcludeUser = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right False)
where
segment =
Segment
{ key = "test"
, included = HS.empty
, includedContexts = mempty
, excluded = HS.fromList ["foo"]
, excludedContexts = mempty
, salt = "abcdef"
, rules = []
, version = 1
, deleted = False
}
user = makeContext "foo" "user"
testExplicitExcludeContextKind :: Test
testExplicitExcludeContextKind = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right False)
where
segment =
Segment
{ key = "test"
, included = HS.empty
, includedContexts = mempty
, excluded = HS.empty
, excludedContexts = [SegmentTarget {values = HS.fromList ["foo"], contextKind = "user"}]
, salt = "abcdef"
, rules = []
, version = 1
, deleted = False
}
user = makeContext "foo" "user"
testExplicitIncludeHasPrecedence :: Test
testExplicitIncludeHasPrecedence = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right True)
where
segment =
Segment
{ key = "test"
, included = HS.fromList ["foo"]
, includedContexts = mempty
, excluded = HS.fromList ["foo"]
, excludedContexts = mempty
, salt = "abcdef"
, rules = []
, version = 1
, deleted = False
}
user = makeContext "foo" "user"
testExplicitIncludeContextsHasPrecedence :: Test
testExplicitIncludeContextsHasPrecedence = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right True)
where
segment =
Segment
{ key = "test"
, included = HS.empty
, includedContexts = [SegmentTarget {values = HS.fromList ["foo"], contextKind = "user"}]
, excluded = HS.fromList ["foo"]
, excludedContexts = [SegmentTarget {values = HS.fromList ["foo"], contextKind = "user"}]
, salt = "abcdef"
, rules = []
, version = 1
, deleted = False
}
user = makeContext "foo" "user"
testNeitherIncludedNorExcluded :: Test
testNeitherIncludedNorExcluded = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right False)
where
segment =
Segment
{ key = "test"
, included = HS.fromList [""]
, includedContexts = mempty
, excluded = HS.fromList [""]
, excludedContexts = mempty
, salt = "abcdef"
, rules = []
, version = 1
, deleted = False
}
user = makeContext "foo" "user"
testMatchingRuleWithFullRollout :: Test
testMatchingRuleWithFullRollout = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment context HS.empty >>= assertEqual "" (Right True)
where
segment =
Segment
{ key = "test"
, included = HS.empty
, includedContexts = mempty
, excluded = HS.empty
, excludedContexts = mempty
, salt = "abcdef"
, rules =
[ SegmentRule
{ id = "rule"
, clauses =
[ Clause
{ attribute = makeLiteral "email"
, contextKind = "user"
, negate = False
, op = OpIn
, values = [String "test@example.com"]
}
]
, weight = Just 100000
, bucketBy = Nothing
, rolloutContextKind = Just "user"
}
]
, version = 1
, deleted = False
}
context = makeContext "foo" "user" & withAttribute "email" "test@example.com"
testMatchingRuleWithZeroRollout :: Test
testMatchingRuleWithZeroRollout = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment context HS.empty >>= assertEqual "" (Right False)
where
segment =
Segment
{ key = "test"
, included = HS.empty
, includedContexts = mempty
, excluded = HS.empty
, excludedContexts = mempty
, salt = "abcdef"
, rules =
[ SegmentRule
{ id = "rule"
, clauses =
[ Clause
{ attribute = makeLiteral "email"
, contextKind = "user"
, negate = False
, op = OpIn
, values = [String "test@example.com"]
}
]
, weight = Just 0
, bucketBy = Nothing
, rolloutContextKind = Just "user"
}
]
, version = 1
, deleted = False
}
context = makeContext "foo" "user" & withAttribute "email" "test@example.com"
testMatchingRuleWithMultipleClauses :: Test
testMatchingRuleWithMultipleClauses = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment context HS.empty >>= assertEqual "" (Right True)
where
segment =
Segment
{ key = "test"
, included = HS.empty
, includedContexts = mempty
, excluded = HS.empty
, excludedContexts = mempty
, salt = "abcdef"
, rules =
[ SegmentRule
{ id = "rule"
, clauses =
[ Clause
{ attribute = makeLiteral "email"
, contextKind = "user"
, negate = False
, op = OpIn
, values = [String "test@example.com"]
}
, Clause
{ attribute = makeLiteral "name"
, contextKind = "user"
, negate = False
, op = OpIn
, values = ["bob"]
}
]
, weight = Nothing
, bucketBy = Nothing
, rolloutContextKind = Just "user"
}
]
, version = 1
, deleted = False
}
context =
makeContext "foo" "user"
& withAttribute "email" "test@example.com"
& withAttribute "name" "bob"
testNonMatchingRuleWithMultipleClauses :: Test
testNonMatchingRuleWithMultipleClauses = TestCase $ do
store <- makeEmptyStore
segmentContainsContext store segment context HS.empty >>= assertEqual "" (Right False)
where
segment =
Segment
{ key = "test"
, included = HS.empty
, includedContexts = mempty
, excluded = HS.empty
, excludedContexts = mempty
, salt = "abcdef"
, rules =
[ SegmentRule
{ id = "rule"
, clauses =
[ Clause
{ attribute = makeLiteral "email"
, contextKind = "user"
, negate = False
, op = OpIn
, values = [String "test@example.com"]
}
, Clause
{ attribute = makeLiteral "name"
, contextKind = "user"
, negate = False
, op = OpIn
, values = ["bill"]
}
]
, weight = Nothing
, bucketBy = Nothing
, rolloutContextKind = Just "user"
}
]
, version = 1
, deleted = False
}
context =
makeContext "foo" "user"
& withAttribute "email" "test@example.com"
& withAttribute "name" "bob"
testCanDetectRecursiveSegments :: Test
testCanDetectRecursiveSegments = TestCase $ do
client <- makeTestClient
insertFlag (getField @"store" client) flag >>= (pure () @=?)
insertSegment (getField @"store" client) segmentA >>= (pure () @=?)
insertSegment (getField @"store" client) segmentB >>= (pure () @=?)
boolVariationDetail client "a" (makeContext "b" "user") False >>= (expected @=?)
where
flag =
(makeTestFlag "a" 1)
{ on = True
, rules =
[ Rule
{ clauses =
[ Clause
{ attribute = makeLiteral "key"
, contextKind = "user"
, op = OpSegmentMatch
, values = [String "segmentA"]
, negate = False
}
]
, variationOrRollout =
VariationOrRollout
{ variation = Just 0
, rollout = Nothing
}
, id = "rule-1"
, trackEvents = False
}
]
, offVariation = Nothing
}
segmentA =
Segment
{ key = "segmentA"
, version = 1
, deleted = False
, included = mempty
, includedContexts = mempty
, excluded = mempty
, excludedContexts = mempty
, salt = ""
, rules =
[ SegmentRule
{ clauses =
[ Clause
{ attribute = makeLiteral "rule-1"
, contextKind = "user"
, op = OpSegmentMatch
, values = [String "segmentB"]
, negate = False
}
]
, id = "rule-1"
, weight = Nothing
, bucketBy = Nothing
, rolloutContextKind = Just "user"
}
]
}
segmentB =
Segment
{ key = "segmentB"
, version = 1
, deleted = False
, included = mempty
, includedContexts = mempty
, excluded = mempty
, excludedContexts = mempty
, salt = ""
, rules =
[ SegmentRule
{ clauses =
[ Clause
{ attribute = makeLiteral "rule-1"
, contextKind = "user"
, op = OpSegmentMatch
, values = [String "segmentA"]
, negate = False
}
]
, id = "rule-1"
, weight = Nothing
, bucketBy = Nothing
, rolloutContextKind = Just "user"
}
]
}
expected =
EvaluationDetail
{ value = False
, variationIndex = Nothing
, reason = EvaluationReasonError {errorKind = EvalErrorKindMalformedFlag}
}
allTests :: Test
allTests =
TestList
[ testExplicitIncludeUser
, testExplicitIncludeContextKind
, testExplicitExcludeUser
, testExplicitExcludeContextKind
, testExplicitIncludeHasPrecedence
, testExplicitIncludeContextsHasPrecedence
, testNeitherIncludedNorExcluded
, testMatchingRuleWithFullRollout
, testMatchingRuleWithZeroRollout
, testMatchingRuleWithMultipleClauses
, testNonMatchingRuleWithMultipleClauses
, testCanDetectRecursiveSegments
]