Establish host properties and isolated kind matrix
This commit is contained in:
parent
84ccfdb445
commit
06d1383456
1 changed files with 1076 additions and 120 deletions
334
test/Spec.hs
334
test/Spec.hs
|
|
@ -1,9 +1,18 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
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
|
||||
|
|
@ -14,88 +23,273 @@ 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 = do
|
||||
assertRight "simple path" (validateRelativePath "a/b.txt")
|
||||
assertLeft "dotdot" (validateRelativePath "a/../b")
|
||||
assertLeft "empty segment" (validateRelativePath "a//b")
|
||||
assertLeft "slash only" (validateRelativePath "/")
|
||||
let uid = encodeUserId "iss" "sub"
|
||||
assertTrue "user id stable" (uid == encodeUserId "iss" "sub")
|
||||
assertTrue "user id differs"
|
||||
(encodeUserId "iss" "sub" /= encodeUserId "iss" "other")
|
||||
let key = buildObjectKey Personal uid (RelativePath "docs/a.txt")
|
||||
assertTrue "personal key prefix" $
|
||||
T.isPrefixOf ("users/" <> unUserId uid <> "/") (unObjectKey key)
|
||||
let shared = buildObjectKey Shared uid (RelativePath "docs/a.txt")
|
||||
assertTrue "shared key" (unObjectKey shared == "shared/docs/a.txt")
|
||||
main = defaultMain tests
|
||||
|
||||
assertTrue "list ancestors nested" $
|
||||
listCacheAncestorPrefixes (RelativePath "docs/a/b.txt")
|
||||
== ["", "docs", "docs/a"]
|
||||
assertTrue "list ancestors root file" $
|
||||
listCacheAncestorPrefixes (RelativePath "file.txt") == [""]
|
||||
tests :: TestTree
|
||||
tests = testGroup "nuthatch-unit"
|
||||
[ pathTests
|
||||
, identityTests
|
||||
, protocolTests
|
||||
]
|
||||
|
||||
let putRec = samplePut
|
||||
assertTrue "put desired present" $
|
||||
desiredMatches putRec (ObjectPresent 10 (Just (ContentSha256 "abc")))
|
||||
assertTrue "put not desired absent" $
|
||||
not (desiredMatches putRec ObjectAbsent)
|
||||
assertTrue "put unavailable not desired" $
|
||||
not (desiredMatches putRec (ObjectUnavailable "timeout"))
|
||||
assertTrue "put prior empty absent" $
|
||||
priorMatches putRec ObjectAbsent
|
||||
assertTrue "put unavailable not prior" $
|
||||
not (priorMatches putRec (ObjectUnavailable "timeout"))
|
||||
let delRec = sampleDelete
|
||||
assertTrue "delete desired absent" $
|
||||
desiredMatches delRec ObjectAbsent
|
||||
assertTrue "delete not desired present" $
|
||||
not (desiredMatches delRec (ObjectPresent 10 Nothing))
|
||||
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") @?= [""]
|
||||
]
|
||||
|
||||
putStrLn "nuthatch-unit: ok"
|
||||
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
|
||||
]
|
||||
|
||||
samplePut :: MutationRecord
|
||||
samplePut = MutationRecord
|
||||
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 = Put
|
||||
, mrKind = kind
|
||||
, mrOperationId = OperationId "op"
|
||||
, mrPoolId = PoolId "personal:u"
|
||||
, mrObjectKey = ObjectKey "users/u/file.txt"
|
||||
, mrRelativePath = RelativePath "file.txt"
|
||||
, mrDeclaredSize = 10
|
||||
, mrContentSha256 = Just (ContentSha256 "abc")
|
||||
, mrObjectKey = key
|
||||
, mrRelativePath = RelativePath "file"
|
||||
, mrDeclaredSize = size
|
||||
, mrContentSha256 = sha
|
||||
, mrPriorSize = 0
|
||||
, mrPriorSha256 = Nothing
|
||||
, mrGrowth = 10
|
||||
, mrGrowth = size
|
||||
, mrState = Applying
|
||||
, mrExternal = ExtSettled
|
||||
}
|
||||
|
||||
sampleDelete :: MutationRecord
|
||||
sampleDelete = samplePut
|
||||
{ mrKind = Delete
|
||||
, mrDeclaredSize = 0
|
||||
, mrContentSha256 = Nothing
|
||||
, mrPriorSize = 10
|
||||
, mrPriorSha256 = Just (ContentSha256 "abc")
|
||||
, mrGrowth = 0
|
||||
}
|
||||
|
||||
assertRight :: String -> Either Text a -> IO ()
|
||||
assertRight label = \case
|
||||
Right _ -> pure ()
|
||||
Left err -> fail (label <> ": " <> T.unpack err)
|
||||
|
||||
assertLeft :: String -> Either Text a -> IO ()
|
||||
assertLeft label = \case
|
||||
Left _ -> pure ()
|
||||
Right _ -> fail (label <> ": expected failure")
|
||||
|
||||
assertTrue :: String -> Bool -> IO ()
|
||||
assertTrue _ True = pure ()
|
||||
assertTrue label False = fail (label <> ": expected True")
|
||||
|
|
|
|||
Loading…
Reference in a new issue