nuthatch/test/Spec.hs

module Main (main) where

import           Data.Either (isLeft)
import           Data.Text (Text)
import qualified Data.Text as T
import           Hedgehog
  ( Gen
  , Property
  , assert
  , forAll
  , property
  , (===)
  )
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import           Nuthatch.Paths
  ( buildObjectKey
  , encodeUserId
  , listCacheAncestorPrefixes
  , validateRelativePath
  )
import           Nuthatch.Protocol
  ( MutationRecord (..)
  , ObjectObservation (..)
  , desiredMatches
  , growthBytes
  , priorMatches
  , quotaAllows
  , recoveryEligible
  , sameFingerprint
  , terminalExpiryEligible
  )
import           Nuthatch.Types
import           Test.Tasty (TestTree, defaultMain, testGroup)
import           Test.Tasty.HUnit ((@?=), testCase)
import           Test.Tasty.Hedgehog (testProperty)

main :: IO ()
main = defaultMain tests

tests :: TestTree
tests = testGroup "nuthatch-unit"
  [ pathTests
  , identityTests
  , protocolTests
  ]

pathTests :: TestTree
pathTests = testGroup "canonical paths"
  [ testProperty "valid paths parse and render without rewriting" propPathRoundTrip
  , testProperty "invalid paths are rejected" propInvalidPaths
  , testProperty "constructed object keys remain under their root" propRootConfinement
  , testCase "nested cache ancestors include every containing listing" $
      listCacheAncestorPrefixes (RelativePath "docs/a/b.txt")
        @?= ["", "docs", "docs/a"]
  , testCase "root files invalidate the root listing" $
      listCacheAncestorPrefixes (RelativePath "file.txt") @?= [""]
  ]

identityTests :: TestTree
identityTests = testGroup "identities"
  [ testProperty "root labels parse back to the same root" propRootLabels
  , testProperty "mutation kind labels parse back to the same kind" propKindLabels
  , testCase "issuer and subject identity encoding remains stable" $
      encodeUserId "https://issuer.example" "subject-α"
        @?= UserId "e0240ab33521a1882fb647a79f7fd3c74c9b6348b29bdb14e572204517882859"
  , testProperty "issuer and subject inputs are separated" propUserIdentitySeparation
  ]

protocolTests :: TestTree
protocolTests = testGroup "mutation protocol decisions"
  [ testProperty "request fingerprints distinguish every bound field" propFingerprintDistinction
  , testProperty "quota growth and admission preserve the limit" propQuotaInvariant
  , testProperty "object observations match the independent classifier" propObservations
  , testProperty "only settled terminal records are expiry eligible" propExpiryEligibility
  , testProperty "only stale active records are recovery eligible" propRecoveryTiming
  ]

newtype ValidPath = ValidPath { getValidPath :: Text }
  deriving stock (Show)

newtype InvalidPath = InvalidPath { getInvalidPath :: Text }
  deriving stock (Show)

genValidPath :: Gen ValidPath
genValidPath = do
  segments <- Gen.list (Range.linear 1 6) genSegment
  pure (ValidPath (T.intercalate "/" segments))
  where
    genSegment =
      Gen.filter (`notElem` [".", ".."]) $
        Gen.text (Range.linear 1 16) $
          Gen.choice [Gen.alphaNum, Gen.element ("_-. " :: String)]

genInvalidPath :: Gen InvalidPath
genInvalidPath = do
  ValidPath valid <- genValidPath
  InvalidPath <$> Gen.element
    [ ""
    , "/" <> valid
    , valid <> "/"
    , valid <> "//tail"
    , valid <> "/../tail"
    , valid <> "/./tail"
    , valid <> "/back\\slash"
    , valid <> "/control\NUL"
    , "e\x0301"
    ]

propPathRoundTrip :: Property
propPathRoundTrip = property $ do
  ValidPath raw <- forAll genValidPath
  validateRelativePath raw === Right (RelativePath raw)

propInvalidPaths :: Property
propInvalidPaths = property $ do
  InvalidPath raw <- forAll genInvalidPath
  assert (isLeft (validateRelativePath raw))

propRootConfinement :: Property
propRootConfinement = property $ do
  ValidPath raw <- forAll genValidPath
  let path = RelativePath raw
      uid = encodeUserId "https://issuer.example" "subject"
      personalPrefix = "users/" <> unUserId uid <> "/"
      personalKey = unObjectKey (buildObjectKey Personal uid path)
      sharedKey = unObjectKey (buildObjectKey Shared uid path)
  assert (personalPrefix `T.isPrefixOf` personalKey)
  assert ("shared/" `T.isPrefixOf` sharedKey)
  assert (not ("shared/" `T.isPrefixOf` personalKey))
  assert (not ("users/" `T.isPrefixOf` sharedKey))

propRootLabels :: Property
propRootLabels = property $ do
  root <- forAll (Gen.element [Personal, Shared])
  parseRoot (rootLabel root) === Just root

propKindLabels :: Property
propKindLabels = property $ do
  kind <- forAll (Gen.element [Put, Delete])
  parseKind (kindLabel kind) === Just kind

propUserIdentitySeparation :: Property
propUserIdentitySeparation = property $ do
  issuer <- forAll genIdentityPart
  subject <- forAll genIdentityPart
  otherIssuer <- forAll (Gen.filter (/= issuer) genIdentityPart)
  other <- forAll (Gen.filter (/= subject) genIdentityPart)
  assert (encodeUserId issuer subject /= encodeUserId otherIssuer subject)
  assert (encodeUserId issuer subject /= encodeUserId issuer other)
  where
    genIdentityPart = Gen.text (Range.linear 1 32) Gen.alphaNum

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
  assert (sameFingerprint rec Put key size sha)
  assert (not (sameFingerprint rec Delete key size sha))
  assert (not (sameFingerprint rec Put otherRootKey size sha))
  assert (not (sameFingerprint rec Put otherPathKey size sha))
  assert (not (sameFingerprint rec Put key (size + 1) sha))
  assert (not (sameFingerprint rec Put key size (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)
        { mrPriorSize = priorSize
        , mrPriorSha256 = 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)

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
  { mrUserId = UserId "u"
  , mrKind = kind
  , mrOperationId = OperationId "op"
  , mrPoolId = PoolId "personal:u"
  , mrObjectKey = key
  , mrRelativePath = RelativePath "file"
  , mrDeclaredSize = size
  , mrContentSha256 = sha
  , mrPriorSize = 0
  , mrPriorSha256 = Nothing
  , mrGrowth = size
  , mrState = Applying
  , mrExternal = ExtSettled
  }