731 lines
25 KiB
Haskell
731 lines
25 KiB
Haskell
module Main (main) where
|
||
|
||
import Control.Monad.IO.Class (liftIO)
|
||
import qualified Data.Aeson as A
|
||
import qualified Data.ByteString as BS
|
||
import qualified Data.ByteString.Lazy as BL
|
||
import Data.Either (isLeft)
|
||
import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
|
||
import Data.Text (Text)
|
||
import qualified Data.Text as T
|
||
import qualified Data.Text.Encoding as TE
|
||
import Hedgehog
|
||
( Gen
|
||
, Property
|
||
, assert
|
||
, forAll
|
||
, property
|
||
, (===)
|
||
)
|
||
import qualified Hedgehog.Gen as Gen
|
||
import qualified Hedgehog.Range as Range
|
||
import Network.HTTP.Types
|
||
( HeaderName
|
||
, methodGet
|
||
, methodPost
|
||
, status200
|
||
, status400
|
||
, status404
|
||
, status405
|
||
)
|
||
import Network.Wai (Request (..))
|
||
import Network.Wai.Test
|
||
( SRequest (..)
|
||
, SResponse (..)
|
||
, defaultRequest
|
||
, runSession
|
||
, setPath
|
||
, srequest
|
||
)
|
||
import Nuthatch.Api
|
||
import Nuthatch.App
|
||
( authenticationHandler
|
||
, loginResponse
|
||
, utf8Boundary
|
||
)
|
||
import Nuthatch.Config (AuthMode (..), Config (..))
|
||
import Nuthatch.Paths
|
||
( buildObjectKey
|
||
, encodeUserId
|
||
, listCacheAncestorPrefixes
|
||
)
|
||
import Nuthatch.Protocol
|
||
( MutationRecord (..)
|
||
, ObjectObservation (..)
|
||
, desiredMatches
|
||
, growthBytes
|
||
, priorMatches
|
||
, quotaAllows
|
||
, recoveryEligible
|
||
, sameFingerprint
|
||
, terminalExpiryEligible
|
||
)
|
||
import Nuthatch.Types
|
||
import Nuthatch.Session (mintSession)
|
||
import Nuthatch.Ui (browsePage, browserScript, loginPage)
|
||
import Servant
|
||
import Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)
|
||
import Servant.Types.SourceT (source)
|
||
import Test.Tasty (TestTree, defaultMain, testGroup)
|
||
import Test.Tasty.HUnit ((@?=), assertBool, testCase)
|
||
import Test.Tasty.Hedgehog (testProperty)
|
||
|
||
main :: IO ()
|
||
main = defaultMain tests
|
||
|
||
tests :: TestTree
|
||
tests = testGroup "nuthatch-unit"
|
||
[ pathTests
|
||
, identityTests
|
||
, protocolTests
|
||
, apiTests
|
||
]
|
||
|
||
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
|
||
, 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")))
|
||
{ mrPriorSize = 10
|
||
, mrPriorSha256 = 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 "only stale active records are recovery eligible" propRecoveryTiming
|
||
]
|
||
|
||
apiTests :: TestTree
|
||
apiTests = testGroup "typed HTTP boundary"
|
||
[ testCase "Servant selects routes and methods" testRouteSelection
|
||
, testCase "valid query values reach a typed handler" testValidDecoding
|
||
, testCase "invalid roots and paths fail before handler execution" testInvalidDomains
|
||
, testCase "malformed UTF-8 fails before handler execution" testMalformedUtf8
|
||
, testCase "upload headers and operation ids decode before streaming handler execution"
|
||
testUploadDecoding
|
||
, testCase "upload and download bodies use Servant streaming endpoints"
|
||
testStreamingEndpoints
|
||
, testCase "operation-specific JSON requests and responses remain distinct"
|
||
testOperationRepresentations
|
||
, testCase "operation-specific errors have closed distinct representations" $ do
|
||
let loginError = A.encode InvalidUsername
|
||
deleteError = A.encode (DeleteMutationRejected "locked")
|
||
prefixError = A.encode (DeletePrefixMutationRejected "partial")
|
||
assertBool "login errors carry the login-specific code"
|
||
("invalid_username" `BS.isInfixOf` BL.toStrict loginError)
|
||
assertBool "delete errors carry the mutation-specific code"
|
||
("mutation_rejected" `BS.isInfixOf` BL.toStrict deleteError)
|
||
assertBool "operation errors must not share one representation"
|
||
(loginError /= deleteError && deleteError /= prefixError)
|
||
assertBool "prefix errors carry their operation-specific code"
|
||
("prefix_mutation_rejected" `BS.isInfixOf` BL.toStrict prefixError)
|
||
, testCase "production authentication validates cookies and login emits both cookies"
|
||
testAuthenticationBoundary
|
||
, testCase "retained browser forms are wired to the typed API bridge"
|
||
testBrowserBridge
|
||
, testCase "links derive from the type-level API" $
|
||
show (linkURI (safeLink api (Proxy :: Proxy HealthEndpoint)))
|
||
@?= "healthz"
|
||
]
|
||
|
||
testRouteSelection :: IO ()
|
||
testRouteSelection = do
|
||
calls <- newIORef 0
|
||
response <- apiRequest calls methodGet "/healthz" [] ""
|
||
simpleStatus response @?= status200
|
||
readIORef calls >>= (@?= 1)
|
||
writeIORef calls 0
|
||
wrongMethod <- apiRequest calls methodPost "/healthz" [] ""
|
||
simpleStatus wrongMethod @?= status405
|
||
readIORef calls >>= (@?= 0)
|
||
missing <- apiRequest calls methodGet "/missing" [] ""
|
||
simpleStatus missing @?= status404
|
||
readIORef calls >>= (@?= 0)
|
||
|
||
testValidDecoding :: IO ()
|
||
testValidDecoding = do
|
||
calls <- newIORef 0
|
||
response <- apiRequest calls methodGet
|
||
"/?root=personal&prefix=docs%2Freports&q=quarterly&continuation=next"
|
||
[]
|
||
""
|
||
simpleStatus response @?= status200
|
||
readIORef calls >>= (@?= 1)
|
||
|
||
testInvalidDomains :: IO ()
|
||
testInvalidDomains = do
|
||
calls <- newIORef 0
|
||
invalidRoot <- apiRequest calls methodGet "/?root=PERSONAL" [] ""
|
||
simpleStatus invalidRoot @?= status400
|
||
invalidPath <- apiRequest calls methodGet "/?prefix=docs%2F..%2Fprivate" [] ""
|
||
simpleStatus invalidPath @?= status400
|
||
readIORef calls >>= (@?= 0)
|
||
|
||
testMalformedUtf8 :: IO ()
|
||
testMalformedUtf8 = do
|
||
calls <- newIORef 0
|
||
response <- apiRequest calls methodGet "/?q=%FF" [] ""
|
||
simpleStatus response @?= status400
|
||
readIORef calls >>= (@?= 0)
|
||
|
||
testUploadDecoding :: IO ()
|
||
testUploadDecoding = do
|
||
calls <- newIORef 0
|
||
let csrf = BS.replicate 43 97
|
||
let headers =
|
||
[ ("Content-Type", "application/octet-stream")
|
||
, ("X-Declared-Size", "4")
|
||
, ("X-Content-SHA256", BS.replicate 64 97)
|
||
, ("X-CSRF-Token", csrf)
|
||
]
|
||
response <- apiRequest calls methodPost
|
||
"/upload?root=personal&path=docs%2Ffile.txt&operation_id=bad%20id"
|
||
headers
|
||
"body"
|
||
simpleStatus response @?= status400
|
||
invalidSize <- apiRequest calls methodPost
|
||
"/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
|
||
(replaceHeader "X-Declared-Size" "zero" headers)
|
||
"body"
|
||
simpleStatus invalidSize @?= status400
|
||
invalidPagination <- apiRequest calls methodGet "/?continuation=" [] ""
|
||
simpleStatus invalidPagination @?= status400
|
||
readIORef calls >>= (@?= 0)
|
||
|
||
testStreamingEndpoints :: IO ()
|
||
testStreamingEndpoints = do
|
||
calls <- newIORef 0
|
||
let csrf = BS.replicate 43 97
|
||
let headers =
|
||
[ ("Content-Type", "application/octet-stream")
|
||
, ("X-Declared-Size", "4")
|
||
, ("X-Content-SHA256", BS.replicate 64 97)
|
||
, ("X-CSRF-Token", csrf)
|
||
]
|
||
upload <- apiRequest calls methodPost
|
||
"/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
|
||
headers
|
||
"body"
|
||
simpleStatus upload @?= status200
|
||
download <- apiRequest calls methodGet
|
||
"/download?root=shared&path=docs%2Ffile.txt"
|
||
[]
|
||
""
|
||
simpleStatus download @?= status200
|
||
simpleBody download @?= "body"
|
||
lookup "Content-Disposition" (simpleHeaders download)
|
||
@?= Just "attachment; filename=\"file.txt\""
|
||
lookup "X-Content-Type-Options" (simpleHeaders download)
|
||
@?= Just "nosniff"
|
||
readIORef calls >>= (@?= 2)
|
||
|
||
testOperationRepresentations :: IO ()
|
||
testOperationRepresentations = do
|
||
calls <- newIORef 0
|
||
login <- apiRequest calls methodPost
|
||
"/login"
|
||
[ ("Content-Type", "application/json")
|
||
, ("Accept", "application/json")
|
||
]
|
||
"{\"username\":\"alice\"}"
|
||
simpleStatus login @?= status200
|
||
assertBool "login response must carry a user identity"
|
||
("user_id" `BS.isInfixOf` BL.toStrict (simpleBody login))
|
||
formLogin <- apiRequest calls methodPost
|
||
"/login"
|
||
[("Content-Type", "application/x-www-form-urlencoded")]
|
||
"username=bob"
|
||
simpleStatus formLogin @?= status200
|
||
assertBool "browser login response navigates into the UI"
|
||
("continue" `BS.isInfixOf` BL.toStrict (simpleBody formLogin))
|
||
invalidLogin <- apiRequest calls methodPost
|
||
"/login"
|
||
[("Content-Type", "application/json")]
|
||
"{\"username\":\"two words\"}"
|
||
simpleStatus invalidLogin @?= status400
|
||
deletion <- apiRequest calls methodPost
|
||
"/delete"
|
||
[("Content-Type", "application/json")]
|
||
"{\"root\":\"shared\",\"path\":\"docs/file.txt\",\"operation_id\":\"delete-1\",\"csrf\":\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"}"
|
||
simpleStatus deletion @?= status200
|
||
assertBool "delete response must carry a mutation result"
|
||
("succeeded" `BS.isInfixOf` BL.toStrict (simpleBody deletion))
|
||
malformed <- apiRequest calls methodPost
|
||
"/delete"
|
||
[("Content-Type", "application/json")]
|
||
"{\"root\":\"shared\",\"path\":\"../escape\"}"
|
||
simpleStatus malformed @?= status400
|
||
readIORef calls >>= (@?= 3)
|
||
|
||
replaceHeader
|
||
:: HeaderName
|
||
-> BS.ByteString
|
||
-> [(HeaderName, BS.ByteString)]
|
||
-> [(HeaderName, BS.ByteString)]
|
||
replaceHeader name value =
|
||
map $ \(headerName, headerValue) ->
|
||
if headerName == name
|
||
then (headerName, value)
|
||
else (headerName, headerValue)
|
||
|
||
apiRequest
|
||
:: IORef Int
|
||
-> BS.ByteString
|
||
-> BS.ByteString
|
||
-> [(HeaderName, BS.ByteString)]
|
||
-> BL.ByteString
|
||
-> IO SResponse
|
||
apiRequest calls method path headers body =
|
||
apiRequestWith (typedTestApplication calls) method path headers body
|
||
|
||
apiRequestWith
|
||
:: Application
|
||
-> BS.ByteString
|
||
-> BS.ByteString
|
||
-> [(HeaderName, BS.ByteString)]
|
||
-> BL.ByteString
|
||
-> IO SResponse
|
||
apiRequestWith app method path headers body =
|
||
runSession
|
||
(srequest
|
||
(SRequest
|
||
(setPath defaultRequest
|
||
{ requestMethod = method
|
||
, requestHeaders = headers
|
||
}
|
||
path)
|
||
body))
|
||
app
|
||
|
||
typedTestApplication :: IORef Int -> Application
|
||
typedTestApplication calls =
|
||
utf8Boundary $
|
||
serveWithContext api (auth :. EmptyContext) (typedTestServer calls)
|
||
where
|
||
auth :: AuthHandler Request SessionContext
|
||
auth = mkAuthHandler $ \_ -> pure SessionContext
|
||
{ sessionUser = SessionUser
|
||
{ suIssuer = "issuer"
|
||
, suSubject = "subject"
|
||
, suUserId = UserId "user"
|
||
, suDisplay = Nothing
|
||
}
|
||
, sessionCsrf = Just
|
||
(CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
|
||
}
|
||
|
||
typedTestServer :: IORef Int -> Server Api
|
||
typedTestServer calls =
|
||
counted (HealthResponse True)
|
||
:<|> counted (ReadyResponse True)
|
||
:<|> counted (HtmlPage "login")
|
||
:<|> counted (BrowserScript "script")
|
||
:<|> (\_ -> counted
|
||
(addHeader "session=cookie"
|
||
(addHeader "csrf=cookie"
|
||
(addHeader (CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
|
||
(LoginView
|
||
(HtmlPage "continue")
|
||
(LoginResponse (UserId "user")))))))
|
||
:<|> (\_ _ -> counted
|
||
(addHeader "session=expired"
|
||
(addHeader "csrf=expired" NoContent)))
|
||
:<|> (\_ _ _ _ _ -> counted
|
||
(BrowseView
|
||
(HtmlPage "browse")
|
||
BrowseResponse
|
||
{ browseEntries = []
|
||
, browseContinuation = Nothing
|
||
, browsePartial = False
|
||
}))
|
||
:<|> (\_ _ _ -> counted
|
||
(addHeader "attachment; filename=\"file.txt\""
|
||
(addHeader "nosniff" (source ["body"]))))
|
||
:<|> (\_ _ _ operation _ _ _ _ -> counted UploadResponse
|
||
{ uploadResponseOperationId = operation
|
||
, uploadResponseResult = MutationSucceeded
|
||
})
|
||
:<|> (\_ request -> counted DeleteResponse
|
||
{ deleteResponseOperationId = deleteOperationId request
|
||
, deleteResponseResult = MutationSucceeded
|
||
})
|
||
:<|> (\_ _ -> counted (DeletePrefixResponse 1))
|
||
where
|
||
counted :: a -> Handler a
|
||
counted value = liftIO (modifyIORef' calls (+ 1)) >> pure value
|
||
|
||
testAuthenticationBoundary :: IO ()
|
||
testAuthenticationBoundary = do
|
||
tokenResult <- mintSession testConfig "issuer" "subject" Nothing
|
||
token <- either (fail . T.unpack) pure tokenResult
|
||
let csrf = CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
||
responseHeaders = getHeaders
|
||
(loginResponse testConfig (UserId "user") token csrf)
|
||
cookieHeaders =
|
||
[ value
|
||
| (name, value) <- responseHeaders
|
||
, name == "Set-Cookie"
|
||
]
|
||
length cookieHeaders @?= 2
|
||
assertBool "login sets the session cookie"
|
||
(any ("nuthatch_session=" `BS.isPrefixOf`) cookieHeaders)
|
||
assertBool "login sets the CSRF cookie"
|
||
(any ("nuthatch_csrf=" `BS.isPrefixOf`) cookieHeaders)
|
||
|
||
calls <- newIORef 0
|
||
let app = productionAuthTestApplication testConfig calls
|
||
cookie =
|
||
"nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token)
|
||
<> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf)
|
||
authenticated <- apiRequestWith app methodGet
|
||
"/?root=personal"
|
||
[("Cookie", cookie)]
|
||
""
|
||
simpleStatus authenticated @?= status200
|
||
readIORef calls >>= (@?= 1)
|
||
|
||
writeIORef calls 0
|
||
malformed <- apiRequestWith app methodGet
|
||
"/?root=personal"
|
||
[("Cookie", "nuthatch_session=" <> BS.singleton 255
|
||
<> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf))]
|
||
""
|
||
simpleStatus malformed @?= status400
|
||
readIORef calls >>= (@?= 0)
|
||
|
||
missingCsrf <- apiRequestWith app methodGet
|
||
"/?root=personal"
|
||
[("Cookie", "nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token))]
|
||
""
|
||
simpleStatus missingCsrf @?= status200
|
||
readIORef calls >>= (@?= 1)
|
||
|
||
testBrowserBridge :: IO ()
|
||
testBrowserBridge = do
|
||
let csrf = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
||
user = SessionUser
|
||
{ suIssuer = "issuer"
|
||
, suSubject = "subject"
|
||
, suUserId = UserId "user"
|
||
, suDisplay = Just "User"
|
||
}
|
||
entry = ListEntry
|
||
{ leName = "folder"
|
||
, leIsPrefix = True
|
||
, leSize = Nothing
|
||
, leRelativePath = "folder"
|
||
}
|
||
browse = browsePage
|
||
user
|
||
Personal
|
||
""
|
||
csrf
|
||
"upload-1"
|
||
["delete-1"]
|
||
[entry]
|
||
Nothing
|
||
""
|
||
assertBool "login page loads the external bridge"
|
||
("/nuthatch.js" `T.isInfixOf` loginPage "")
|
||
mapM_
|
||
(\marker -> assertBool ("browse page includes " <> T.unpack marker)
|
||
(marker `T.isInfixOf` browse))
|
||
[ "data-nuthatch=\"upload\""
|
||
, "data-nuthatch=\"delete\""
|
||
, "data-nuthatch=\"logout\""
|
||
]
|
||
mapM_
|
||
(\endpoint -> assertBool ("bridge calls " <> T.unpack endpoint)
|
||
(endpoint `T.isInfixOf` browserScript))
|
||
[ "/upload"
|
||
, "/delete-prefix"
|
||
, "/logout"
|
||
]
|
||
|
||
productionAuthTestApplication :: Config -> IORef Int -> Application
|
||
productionAuthTestApplication cfg calls =
|
||
utf8Boundary $
|
||
serveWithContext
|
||
api
|
||
(authenticationHandler cfg :. EmptyContext)
|
||
(typedTestServer calls)
|
||
|
||
testConfig :: Config
|
||
testConfig = Config
|
||
{ cfgListenHost = "127.0.0.1"
|
||
, cfgListenPort = 8080
|
||
, cfgPublicBaseUrl = "https://nuthatch.example"
|
||
, cfgJwtSecret = "unit-test-secret-material"
|
||
, cfgSessionHours = 1
|
||
, cfgCookieName = "nuthatch_session"
|
||
, cfgCsrfCookieName = "nuthatch_csrf"
|
||
, cfgPgConn = ""
|
||
, cfgRedisHost = ""
|
||
, cfgRedisPort = 6379
|
||
, cfgRedisDb = 0
|
||
, cfgS3Endpoint = "https://s3.example"
|
||
, cfgS3Region = "test"
|
||
, cfgS3Bucket = "test"
|
||
, cfgS3AccessKey = "test"
|
||
, cfgS3SecretKey = "test"
|
||
, cfgS3PathStyle = True
|
||
, cfgPersonalQuotaBytes = 1024
|
||
, cfgSharedQuotaBytes = 1024
|
||
, cfgMaxObjectBytes = 1024
|
||
, cfgThrottleBytesPerSec = 1024
|
||
, cfgThrottleBurstBytes = 1024
|
||
, cfgListCacheTtlSec = 30
|
||
, cfgSearchMaxKeys = 100
|
||
, cfgRecoveryGraceSec = 30
|
||
, cfgAuthMode = AuthDev
|
||
}
|
||
|
||
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
|
||
}
|