nuthatch/test/Nuthatch/Test/Protocol.hs

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
  }