295 lines
10 KiB
Haskell
295 lines
10 KiB
Haskell
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
|
||
}
|