Split host tests by component ownership

test/Nuthatch/Test/Protocol.hs

@@ -0,0 +1,252 @@
+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
+  }