252 lines
9.2 KiB
Haskell
252 lines
9.2 KiB
Haskell
module Nuthatch.Test.Protocol
|
|
( tests
|
|
) where
|
|
|
|
import Hedgehog
|
|
( Gen
|
|
, Property
|
|
, assert
|
|
, forAll
|
|
, property
|
|
, (===)
|
|
)
|
|
import qualified Hedgehog.Gen as Gen
|
|
import qualified Hedgehog.Range as Range
|
|
import Nuthatch.Paths (buildObjectKey, encodeUserId)
|
|
import Nuthatch.Protocol
|
|
import Nuthatch.Test.PathFixture
|
|
import Nuthatch.Types
|
|
import Test.Tasty (TestTree, testGroup)
|
|
import Test.Tasty.HUnit ((@?=), assertFailure, testCase)
|
|
import Test.Tasty.Hedgehog (testProperty)
|
|
|
|
tests :: TestTree
|
|
tests = testGroup "mutation protocol decisions"
|
|
[ testCase "protocol phases round-trip through persisted state labels" $
|
|
mapM_
|
|
(\phase -> do
|
|
let (state, external) = encodeMutationPhase phase
|
|
decodeMutationPhase state external @?= Just phase)
|
|
[ PhasePrepared
|
|
, PhaseApplying ExtIdle
|
|
, PhaseApplying ExtPending
|
|
, PhaseApplying ExtSettled
|
|
, PhaseTerminal TerminalSucceeded
|
|
, PhaseTerminal TerminalFailed
|
|
, PhaseTerminal TerminalRejected
|
|
]
|
|
, testCase "invalid persisted protocol phase combinations are rejected" $
|
|
mapM_
|
|
(\(state, external) ->
|
|
decodeMutationPhase state external @?= Nothing)
|
|
[ (Prepared, ExtPending)
|
|
, (Prepared, ExtSettled)
|
|
, (Succeeded, ExtPending)
|
|
, (Succeeded, ExtSettled)
|
|
, (Failed, ExtPending)
|
|
, (Failed, ExtSettled)
|
|
, (Rejected, ExtPending)
|
|
, (Rejected, ExtSettled)
|
|
]
|
|
, testProperty "request fingerprints distinguish every bound field"
|
|
propFingerprintDistinction
|
|
, testCase "removed terminal identity starts a new mutation epoch" $ do
|
|
let rec = sampleMutation
|
|
Put
|
|
(ObjectKey "users/u/file")
|
|
4
|
|
(Just (ContentSha256 "content"))
|
|
fingerprint =
|
|
MutationFingerprint Put (mrObjectKey rec) 4 (mrContentSha256 rec)
|
|
case existingDisposition Nothing fingerprint of
|
|
NewMutationEpoch -> pure ()
|
|
other -> assertFailure ("expected new epoch, got " <> show other)
|
|
case existingDisposition (Just rec) fingerprint of
|
|
ExistingReplay MutationPending _ -> pure ()
|
|
other -> assertFailure ("expected replay, got " <> show other)
|
|
case existingDisposition
|
|
(Just rec)
|
|
(fingerprint { fingerprintDeclaredSize = 5 }) of
|
|
ExistingConflict -> pure ()
|
|
other -> assertFailure ("expected conflict, got " <> show other)
|
|
, testProperty "quota growth and admission preserve the limit" propQuotaInvariant
|
|
, testProperty "object observations match the independent classifier"
|
|
propObservations
|
|
, testCase "unavailable observations match no terminal state" $ do
|
|
let rec = sampleMutation Put (ObjectKey "shared/file") 10
|
|
(Just (ContentSha256 "desired"))
|
|
observation = ObjectUnavailable "timeout"
|
|
desiredMatches rec observation @?= False
|
|
priorMatches rec observation @?= False
|
|
, testCase "ambiguous same-size content matches no terminal state" $ do
|
|
let rec = (sampleMutation Put (ObjectKey "shared/file") 10
|
|
(Just (ContentSha256 "desired")))
|
|
{ mrPriorObject =
|
|
PriorObject 10 (Just (ContentSha256 "prior"))
|
|
}
|
|
observation = ObjectPresent 10 (Just (ContentSha256 "other"))
|
|
desiredMatches rec observation @?= False
|
|
priorMatches rec observation @?= False
|
|
, testProperty "only settled terminal records are expiry eligible"
|
|
propExpiryEligibility
|
|
, testProperty "terminal identities expire only after the window"
|
|
propTerminalExpiry
|
|
, testProperty "only stale active records are recovery eligible"
|
|
propRecoveryTiming
|
|
]
|
|
|
|
propFingerprintDistinction :: Property
|
|
propFingerprintDistinction = property $ do
|
|
ValidPath raw <- forAll genValidPath
|
|
size <- forAll (Gen.integral (Range.linear 1 1000000))
|
|
let uid = encodeUserId "issuer" "subject"
|
|
key = buildObjectKey Personal uid (RelativePath raw)
|
|
otherRootKey = buildObjectKey Shared uid (RelativePath raw)
|
|
otherPathKey = buildObjectKey Personal uid (RelativePath ("other/" <> raw))
|
|
sha = Just (ContentSha256 "content-a")
|
|
rec = sampleMutation Put key size sha
|
|
fingerprint = MutationFingerprint Put key size sha
|
|
assert (sameFingerprint rec fingerprint)
|
|
assert (not (sameFingerprint rec
|
|
(fingerprint { fingerprintKind = Delete })))
|
|
assert (not (sameFingerprint rec
|
|
(fingerprint { fingerprintObjectKey = otherRootKey })))
|
|
assert (not (sameFingerprint rec
|
|
(fingerprint { fingerprintObjectKey = otherPathKey })))
|
|
assert (not (sameFingerprint rec
|
|
(fingerprint { fingerprintDeclaredSize = size + 1 })))
|
|
assert (not (sameFingerprint rec
|
|
(fingerprint
|
|
{ fingerprintContentSha256 = Just (ContentSha256 "content-b") })))
|
|
|
|
propQuotaInvariant :: Property
|
|
propQuotaInvariant = property $ do
|
|
prior <- forAll nonNegativeBytes
|
|
desired <- forAll nonNegativeBytes
|
|
used <- forAll nonNegativeBytes
|
|
reserved <- forAll nonNegativeBytes
|
|
limit <- forAll nonNegativeBytes
|
|
let growth = growthBytes prior desired
|
|
modelGrowth = max 0 (desired - prior)
|
|
allowed = quotaAllows limit used reserved growth
|
|
growth === modelGrowth
|
|
assert (growth >= 0)
|
|
allowed === (used + reserved + modelGrowth <= limit)
|
|
if allowed
|
|
then assert (used + reserved + growth <= limit)
|
|
else assert (used + reserved + growth > limit)
|
|
where
|
|
nonNegativeBytes = Gen.integral (Range.linear 0 1000000000)
|
|
|
|
propObservations :: Property
|
|
propObservations = property $ do
|
|
kind <- forAll (Gen.element [Put, Delete])
|
|
desiredSize <- forAll (Gen.integral (Range.linear 1 1000000))
|
|
priorSize <- forAll (Gen.integral (Range.linear 0 1000000))
|
|
observation <- forAll genObservation
|
|
let desiredSha = Just (ContentSha256 "desired")
|
|
priorSha = if priorSize == 0 then Nothing else Just (ContentSha256 "prior")
|
|
rec = (sampleMutation kind (ObjectKey "users/u/file") desiredSize desiredSha)
|
|
{ mrPriorObject = PriorObject priorSize priorSha }
|
|
desiredMatches rec observation
|
|
=== modelDesired kind desiredSize desiredSha observation
|
|
priorMatches rec observation === modelPrior priorSize priorSha observation
|
|
|
|
propExpiryEligibility :: Property
|
|
propExpiryEligibility = property $ do
|
|
state <- forAll genMutationState
|
|
external <- forAll genExternalState
|
|
terminalExpiryEligible state external
|
|
=== (state `elem` [Succeeded, Failed, Rejected] && external == ExtIdle)
|
|
|
|
propTerminalExpiry :: Property
|
|
propTerminalExpiry = property $ do
|
|
state <- forAll genMutationState
|
|
external <- forAll genExternalState
|
|
elapsed <- forAll (Gen.integral (Range.linear 0 10000))
|
|
window <- forAll (Gen.integral (Range.linear 1 10000))
|
|
terminalExpired state external elapsed window
|
|
=== ( state `elem` [Succeeded, Failed, Rejected]
|
|
&& external == ExtIdle
|
|
&& elapsed > window
|
|
)
|
|
|
|
propRecoveryTiming :: Property
|
|
propRecoveryTiming = property $ do
|
|
state <- forAll genMutationState
|
|
elapsed <- forAll (Gen.integral (Range.linear 0 10000))
|
|
grace <- forAll (Gen.integral (Range.linear 0 10000))
|
|
recoveryEligible state elapsed grace
|
|
=== (state `elem` [Prepared, Applying] && elapsed > grace)
|
|
|
|
genObservation :: Gen ObjectObservation
|
|
genObservation = Gen.choice
|
|
[ pure ObjectAbsent
|
|
, pure (ObjectUnavailable "dependency unavailable")
|
|
, ObjectPresent
|
|
<$> Gen.integral (Range.linear 0 1000000)
|
|
<*> Gen.element
|
|
[ Nothing
|
|
, Just (ContentSha256 "desired")
|
|
, Just (ContentSha256 "prior")
|
|
, Just (ContentSha256 "other")
|
|
]
|
|
]
|
|
|
|
modelDesired
|
|
:: MutationKind
|
|
-> Integer
|
|
-> Maybe ContentSha256
|
|
-> ObjectObservation
|
|
-> Bool
|
|
modelDesired kind size sha observation =
|
|
case (kind, observation) of
|
|
(Delete, ObjectAbsent) -> True
|
|
(Put, ObjectPresent observedSize observedSha) ->
|
|
observedSize == size
|
|
&& case (sha, observedSha) of
|
|
(Just expected, Just actual) -> expected == actual
|
|
(Just _, Nothing) -> False
|
|
(Nothing, _) -> True
|
|
_ -> False
|
|
|
|
modelPrior
|
|
:: Integer
|
|
-> Maybe ContentSha256
|
|
-> ObjectObservation
|
|
-> Bool
|
|
modelPrior size sha observation =
|
|
case observation of
|
|
ObjectUnavailable _ -> False
|
|
ObjectAbsent -> size == 0 && sha == Nothing
|
|
ObjectPresent observedSize observedSha ->
|
|
observedSize == size
|
|
&& case (sha, observedSha) of
|
|
(Just expected, Just actual) -> expected == actual
|
|
(Nothing, Nothing) -> True
|
|
(Just _, Nothing) -> False
|
|
(Nothing, Just _) -> True
|
|
|
|
genMutationState :: Gen MutationState
|
|
genMutationState =
|
|
Gen.element [Prepared, Applying, Succeeded, Failed, Rejected]
|
|
|
|
genExternalState :: Gen ExternalState
|
|
genExternalState = Gen.element [ExtIdle, ExtPending, ExtSettled]
|
|
|
|
sampleMutation
|
|
:: MutationKind
|
|
-> ObjectKey
|
|
-> Integer
|
|
-> Maybe ContentSha256
|
|
-> MutationRecord
|
|
sampleMutation kind key size sha = MutationRecord
|
|
{ mrAdmissionIdentity =
|
|
AdmissionIdentity (UserId "u") kind (OperationId "op")
|
|
, mrPoolId = PoolId "personal:u"
|
|
, mrRelativePath = RelativePath "file"
|
|
, mrFingerprint = MutationFingerprint kind key size sha
|
|
, mrPriorObject = PriorObject 0 Nothing
|
|
, mrGrowth = size
|
|
, mrPhase = PhaseApplying ExtSettled
|
|
}
|